Tricu 2.0.0
Sorry for squashing all of this but 🤷
This commit is contained in:
42
src/Check.hs
Normal file
42
src/Check.hs
Normal file
@@ -0,0 +1,42 @@
|
||||
module Check
|
||||
( module Check.Core
|
||||
, module Check.IO
|
||||
, checkFile
|
||||
, checkFileWithStore
|
||||
, checkSource
|
||||
) where
|
||||
|
||||
import Check.Core
|
||||
import Check.IO
|
||||
import ContentStore (ObjectRef, StorePath, getViewType)
|
||||
import Eval (evalTricu)
|
||||
import FileEval (LoadedSource(..), defaultStorePath, evaluateFile, evaluateFileWithStore, loadFileWithStore)
|
||||
import Research (Env, ViewType)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
checkFile :: FilePath -> IO String
|
||||
checkFile path = do
|
||||
store <- defaultStorePath
|
||||
checkFileWithStore store path
|
||||
|
||||
checkFileWithStore :: StorePath -> FilePath -> IO String
|
||||
checkFileWithStore store path = do
|
||||
loaded <- loadFileWithStore store path
|
||||
viewEnv <- evaluateFileWithStore (Just store) "./lib/view.tri"
|
||||
let baseEnv = Map.union viewEnv (loadedImports loaded)
|
||||
checkerEnv = evalTricu baseEnv (loadedAst loaded)
|
||||
imports <- importedViewsFromResolvedModulesEither (loadImportedView store) (loadedModules loaded)
|
||||
checkProgramWithEnvAndImportedViews checkerEnv imports (loadedAst loaded)
|
||||
|
||||
viewCheckerEnv :: Env
|
||||
viewCheckerEnv = unsafePerformIO (evaluateFile "./lib/view.tri")
|
||||
{-# NOINLINE viewCheckerEnv #-}
|
||||
|
||||
checkSource :: String -> IO String
|
||||
checkSource = checkSourceWithEnv viewCheckerEnv
|
||||
|
||||
loadImportedView :: StorePath -> ObjectRef -> IO (Either String ViewType)
|
||||
loadImportedView = getViewType
|
||||
751
src/Check/Core.hs
Normal file
751
src/Check/Core.hs
Normal file
@@ -0,0 +1,751 @@
|
||||
module Check.Core
|
||||
( ImportedView(..)
|
||||
, importedViewsFromResolvedModules
|
||||
, importedViewsFromResolvedModulesEither
|
||||
, checkProgramWithEnvAndImportedViews
|
||||
, checkSourceWithEnv
|
||||
, checkSourceWithEnvAndImportedViews
|
||||
, lowerSource
|
||||
, lowerSourceWithDebug
|
||||
, lowerSourceWithImportedViews
|
||||
, lowerSourceWithImportedViewsDebug
|
||||
, lowerViewExpr
|
||||
) where
|
||||
|
||||
import Control.Monad.State.Strict
|
||||
import Data.Char (isDigit)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
|
||||
import ContentStore.Alias (ObjectRef(..))
|
||||
import Eval (evalTricu, result)
|
||||
import Module.Resolver
|
||||
( ResolvedExport(..)
|
||||
, ResolvedModule(..)
|
||||
)
|
||||
import Parser (parseTricu)
|
||||
import Research
|
||||
|
||||
data ImportedView = ImportedView
|
||||
{ importedViewName :: String
|
||||
, importedViewType :: ViewType
|
||||
} deriving (Show, Eq)
|
||||
|
||||
-- Convert module-resolution metadata into checker evidence inputs. The loader
|
||||
-- decodes a portable view artifact into a syntactic ViewType, but this function
|
||||
-- does not judge compatibility or policy. It only says: this resolved imported
|
||||
-- name has an advertised view fact that should be emitted into the typed program.
|
||||
importedViewsFromResolvedModules :: (ObjectRef -> IO (Maybe ViewType)) -> [ResolvedModule] -> IO [ImportedView]
|
||||
importedViewsFromResolvedModules loadView = importedViewsFromResolvedModulesEither loadViewEither
|
||||
where
|
||||
loadViewEither ref = do
|
||||
mView <- loadView ref
|
||||
pure $ maybe (Left "artifact not found or could not be decoded") Right mView
|
||||
|
||||
importedViewsFromResolvedModulesEither :: (ObjectRef -> IO (Either String ViewType)) -> [ResolvedModule] -> IO [ImportedView]
|
||||
importedViewsFromResolvedModulesEither loadView modules = concat <$> mapM fromModule modules
|
||||
where
|
||||
fromModule m = concat <$> mapM fromExport (resolvedModuleExports m)
|
||||
|
||||
fromExport ex = case resolvedExportView ex of
|
||||
Nothing -> pure []
|
||||
Just ref -> do
|
||||
eView <- loadView ref
|
||||
case eView of
|
||||
Left err -> errorWithoutStackTrace $
|
||||
"View Contract artifact invalid for imported export "
|
||||
++ show (resolvedExportLocalName ex)
|
||||
++ " (kind " ++ showRefKind ref ++ ", hash " ++ showRefHash ref ++ "): "
|
||||
++ err
|
||||
Right view -> pure [ImportedView (resolvedExportLocalName ex) view]
|
||||
|
||||
showRefKind = T.unpack . objectRefKind
|
||||
showRefHash = T.unpack . objectRefHash
|
||||
|
||||
checkSourceWithEnv :: Env -> String -> IO String
|
||||
checkSourceWithEnv checkerEnv = checkSourceWithEnvAndImportedViews checkerEnv []
|
||||
|
||||
checkSourceWithEnvAndImportedViews :: Env -> [ImportedView] -> String -> IO String
|
||||
checkSourceWithEnvAndImportedViews checkerEnv imports source =
|
||||
checkProgramWithEnvAndImportedViews checkerEnv imports (parseTricu source)
|
||||
|
||||
checkProgramWithEnvAndImportedViews :: Env -> [ImportedView] -> [TricuAST] -> IO String
|
||||
checkProgramWithEnvAndImportedViews checkerEnv imports asts = do
|
||||
case lowerProgramWithImportedViewsDebugInEnv checkerEnv imports asts of
|
||||
Left err -> pure err
|
||||
Right (typedProgramSource, debugNames) -> do
|
||||
let input =
|
||||
"matchResult " ++
|
||||
"(diag env : renderDiagnostic diag) " ++
|
||||
"(exec env : matchResult (runtimeDiag runtimeEnv : renderDiagnostic runtimeDiag) (_ runtimeEnv : \"ok\") (runChecked exec)) " ++
|
||||
"(checkTypedProgramWith policyStrict " ++ parens typedProgramSource ++ ")"
|
||||
let env = evalTricu checkerEnv (parseTricu input)
|
||||
pure $ case toString (result env) of
|
||||
Right s -> annotateDiagnostic debugNames s
|
||||
Left _ -> formatT Decode (result env)
|
||||
|
||||
-- Debug names are a frontend-only side table. The portable checker renders
|
||||
-- canonical numeric-symbol diagnostics; the CLI annotates that presentation
|
||||
-- afterward without feeding labels back into checker semantics.
|
||||
annotateDiagnostic :: Map.Map Integer String -> String -> String
|
||||
annotateDiagnostic debugNames message =
|
||||
case words message of
|
||||
("symbol" : symText : rest)
|
||||
| all isDigit symText
|
||||
, Just label <- Map.lookup (read symText) debugNames ->
|
||||
"symbol " ++ symText ++ " (" ++ label ++ ") " ++ unwords rest
|
||||
_ -> message
|
||||
|
||||
lowerSource :: String -> Either String String
|
||||
lowerSource = lowerProgram . parseTricu
|
||||
|
||||
lowerSourceWithDebug :: String -> Either String (String, Map.Map Integer String)
|
||||
lowerSourceWithDebug = lowerProgramWithDebug . parseTricu
|
||||
|
||||
lowerSourceWithImportedViews :: [ImportedView] -> String -> Either String String
|
||||
lowerSourceWithImportedViews imports = lowerProgramWithImportedViews imports . parseTricu
|
||||
|
||||
lowerSourceWithImportedViewsDebug :: [ImportedView] -> String -> Either String (String, Map.Map Integer String)
|
||||
lowerSourceWithImportedViewsDebug imports = lowerProgramWithImportedViewsDebug imports . parseTricu
|
||||
|
||||
-- Symbol allocation is intentionally deterministic so emitted view-tree
|
||||
-- nodes are stable and lower-only tests can inspect them directly:
|
||||
--
|
||||
-- * top-level definitions receive symbols 0..n-1 in source order;
|
||||
-- * local binders, literals, application results, and synthetic typed nodes
|
||||
-- are allocated monotonically from nextSym;
|
||||
-- * external names are allocated on first reference and then reused.
|
||||
--
|
||||
-- Symbols are view-tree node identifiers only. Checker semantics remain in
|
||||
-- lib/view.tri; the frontend only emits typed/checkable structure about these
|
||||
-- symbols.
|
||||
data LowerState = LowerState
|
||||
{ nextSym :: Integer
|
||||
, topSyms :: Map.Map String Integer
|
||||
, scopes :: [Map.Map String Integer]
|
||||
, externSyms :: Map.Map String Integer
|
||||
, knownNodeViews :: Map.Map Integer ViewExpr
|
||||
, nodePayloads :: Map.Map Integer T
|
||||
, debugNames :: Map.Map Integer String
|
||||
}
|
||||
|
||||
type LowerM a = StateT LowerState (Either String) a
|
||||
|
||||
lowerProgram :: [TricuAST] -> Either String String
|
||||
lowerProgram asts = fst <$> lowerProgramWithDebug asts
|
||||
|
||||
lowerProgramWithDebug :: [TricuAST] -> Either String (String, Map.Map Integer String)
|
||||
lowerProgramWithDebug = lowerProgramWithImportedViewsDebug []
|
||||
|
||||
lowerProgramWithImportedViews :: [ImportedView] -> [TricuAST] -> Either String String
|
||||
lowerProgramWithImportedViews imports asts = fst <$> lowerProgramWithImportedViewsDebug imports asts
|
||||
|
||||
lowerProgramWithImportedViewsDebug :: [ImportedView] -> [TricuAST] -> Either String (String, Map.Map Integer String)
|
||||
lowerProgramWithImportedViewsDebug = lowerProgramWithImportedViewsDebugInEnv Map.empty
|
||||
|
||||
lowerProgramWithImportedViewsDebugInEnv :: Env -> [ImportedView] -> [TricuAST] -> Either String (String, Map.Map Integer String)
|
||||
lowerProgramWithImportedViewsDebugInEnv checkerEnvForLowering imports asts = do
|
||||
let definitions = [ def | def <- asts, isDefinition def ]
|
||||
topNames = map definitionName definitions
|
||||
tops = Map.fromList (zip topNames [0..])
|
||||
topCount = Map.size tops
|
||||
importedSyms = Map.fromList
|
||||
[ (importedViewName imported, fromIntegral (topCount + idx))
|
||||
| (idx, imported) <- zip [0..] imports
|
||||
]
|
||||
topDebug = Map.fromList [ (sym, name) | (name, sym) <- Map.toList tops ]
|
||||
importDebug = Map.fromList
|
||||
[ (sym, "imported " ++ name)
|
||||
| (name, sym) <- Map.toList importedSyms
|
||||
]
|
||||
importKnown = Map.fromList
|
||||
[ (sym, viewTypeToExpr (importedViewType imported))
|
||||
| imported <- imports
|
||||
, Just sym <- [Map.lookup (importedViewName imported) importedSyms]
|
||||
]
|
||||
payloads = Map.fromList $
|
||||
[ (sym, term)
|
||||
| (name, sym) <- Map.toList tops
|
||||
, Just term <- [Map.lookup name checkerEnvForLowering]
|
||||
] ++
|
||||
[ (sym, term)
|
||||
| (name, sym) <- Map.toList importedSyms
|
||||
, Just term <- [Map.lookup name checkerEnvForLowering]
|
||||
]
|
||||
annotated = [ def | def@SDefAnn {} <- asts ]
|
||||
initialState = LowerState
|
||||
{ nextSym = fromIntegral (Map.size tops + Map.size importedSyms)
|
||||
, topSyms = tops
|
||||
, scopes = []
|
||||
, externSyms = importedSyms
|
||||
, knownNodeViews = importKnown
|
||||
, nodePayloads = payloads
|
||||
, debugNames = Map.union topDebug importDebug
|
||||
}
|
||||
(localNodes, finalState) <- runStateT (lowerAnnotatedProgram annotated) initialState
|
||||
importNodes <- mapM (lowerImportedView (nodePayloads finalState))
|
||||
[ (sym, viewTypeToExpr (importedViewType imported))
|
||||
| imported <- imports
|
||||
, Just sym <- [Map.lookup (importedViewName imported) importedSyms]
|
||||
]
|
||||
let nodes = importNodes ++ localNodes
|
||||
rootSym = if null nodes then 0 else nextSym finalState - 1
|
||||
typedProgramSource =
|
||||
"typedProgram " ++ show rootSym ++ " [" ++ unwords (map parens nodes) ++ "]"
|
||||
pure (typedProgramSource, debugNames finalState)
|
||||
lowerImportedView :: Map.Map Integer T -> (Integer, ViewExpr) -> Either String String
|
||||
lowerImportedView payloadsBySym (sym, view) = do
|
||||
viewExpr <- lowerViewExpr view
|
||||
let payload = maybe "t" treeSource (Map.lookup sym payloadsBySym)
|
||||
pure $ "typedValue " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload
|
||||
|
||||
lowerAnnotatedProgram :: [TricuAST] -> LowerM [String]
|
||||
lowerAnnotatedProgram defs = do
|
||||
declarations <- concat <$> mapM lowerDefinitionDeclaration defs
|
||||
flows <- concat <$> mapM lowerDefinitionFlow defs
|
||||
pure (declarations ++ flows)
|
||||
|
||||
lowerDefinitionDeclaration :: TricuAST -> LowerM [String]
|
||||
lowerDefinitionDeclaration (SDefAnn name args ret _) = do
|
||||
sym <- symbolForTop name
|
||||
argViews <- mapM lowerArgView args
|
||||
retExpr <- liftEither (maybe (Right "viewAny") lowerViewExpr ret)
|
||||
recordKnown sym (declaredDefinitionView args ret)
|
||||
node <- emitDeclaration sym argViews retExpr
|
||||
pure [node]
|
||||
lowerDefinitionDeclaration _ = liftEither (Left "internal check error: expected annotated definition")
|
||||
|
||||
lowerDefinitionFlow :: TricuAST -> LowerM [String]
|
||||
lowerDefinitionFlow (SDefAnn _ args ret body) = withDefinitionScope args $ do
|
||||
binderNodes <- concat <$> mapM lowerBinderDeclaration args
|
||||
let phantomViews = map lowerPhantomArgType (phantomArgs args)
|
||||
(returnArgs, returnResult) <- lowerReturnObligation ret
|
||||
bodyNodes <- lowerBodyWithPhantoms (phantomViews ++ returnArgs) returnResult body
|
||||
pure (binderNodes ++ bodyNodes)
|
||||
lowerDefinitionFlow _ = liftEither (Left "internal check error: expected annotated definition")
|
||||
|
||||
viewAnyType :: ViewExpr
|
||||
viewAnyType = VEName "Any"
|
||||
|
||||
declaredDefinitionView :: [DefArg] -> Maybe ViewExpr -> ViewExpr
|
||||
declaredDefinitionView args ret =
|
||||
case map argType args of
|
||||
[] -> resultType
|
||||
views -> viewExprFn views resultType
|
||||
where
|
||||
resultType = maybe viewAnyType id ret
|
||||
|
||||
argType :: DefArg -> ViewExpr
|
||||
argType (DefBinder _ Nothing) = viewAnyType
|
||||
argType (DefBinder _ (Just ty)) = ty
|
||||
argType (DefPhantom ty) = ty
|
||||
|
||||
emitDeclaration :: Integer -> [String] -> String -> LowerM String
|
||||
emitDeclaration sym [] retExpr = do
|
||||
payload <- payloadSourceFor sym
|
||||
pure $ "typedValue " ++ show sym ++ " " ++ parens retExpr ++ " " ++ payload
|
||||
emitDeclaration sym views retExpr = do
|
||||
payload <- payloadSourceFor sym
|
||||
pure $ "typedValue " ++ show sym ++ " (viewFn [" ++ unwords (map parens views) ++ "] " ++ parens retExpr ++ ") " ++ payload
|
||||
|
||||
typedValueNode :: Integer -> ViewExpr -> LowerM String
|
||||
typedValueNode sym view = do
|
||||
viewExpr <- liftEither (lowerViewExpr view)
|
||||
payload <- payloadSourceFor sym
|
||||
pure ("typedValue " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload)
|
||||
|
||||
typedRequireNode :: Integer -> ViewExpr -> LowerM String
|
||||
typedRequireNode sym view = do
|
||||
viewExpr <- liftEither (lowerViewExpr view)
|
||||
payload <- payloadSourceFor sym
|
||||
pure ("typedRequire " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload)
|
||||
|
||||
declareKnown :: Integer -> ViewExpr -> LowerM String
|
||||
declareKnown sym view = do
|
||||
recordKnown sym view
|
||||
typedValueNode sym view
|
||||
|
||||
declareKnownWithPayload :: Integer -> ViewExpr -> T -> LowerM String
|
||||
declareKnownWithPayload sym view payload = do
|
||||
recordPayload sym payload
|
||||
declareKnown sym view
|
||||
|
||||
declareKnownFresh :: ViewExpr -> LowerM (Integer, [String])
|
||||
declareKnownFresh view = do
|
||||
sym <- freshSym
|
||||
node <- declareKnown sym view
|
||||
pure (sym, [node])
|
||||
|
||||
declareKnownFreshWithPayload :: ViewExpr -> T -> LowerM (Integer, [String])
|
||||
declareKnownFreshWithPayload view payload = do
|
||||
sym <- freshSym
|
||||
node <- declareKnownWithPayload sym view payload
|
||||
pure (sym, [node])
|
||||
|
||||
declareAndRequireFresh :: ViewExpr -> LowerM (Integer, [String])
|
||||
declareAndRequireFresh view = do
|
||||
sym <- freshSym
|
||||
declareNode <- declareKnown sym view
|
||||
requireNode <- typedRequireNode sym view
|
||||
pure (sym, [declareNode, requireNode])
|
||||
|
||||
declareAndRequireFreshWithPayload :: ViewExpr -> T -> LowerM (Integer, [String])
|
||||
declareAndRequireFreshWithPayload view payload = do
|
||||
sym <- freshSym
|
||||
declareNode <- declareKnownWithPayload sym view payload
|
||||
requireNode <- typedRequireNode sym view
|
||||
pure (sym, [declareNode, requireNode])
|
||||
|
||||
lowerBinderDeclaration :: DefArg -> LowerM [String]
|
||||
lowerBinderDeclaration (DefBinder name mTy) = do
|
||||
sym <- symbolForLocal name
|
||||
node <- declareKnown sym (maybe viewAnyType id mTy)
|
||||
pure [node]
|
||||
lowerBinderDeclaration (DefPhantom _) = pure []
|
||||
|
||||
lowerBodyWithPhantoms :: [ViewExpr] -> ViewExpr -> TricuAST -> LowerM [String]
|
||||
lowerBodyWithPhantoms [] _ SLambda {} = pure []
|
||||
lowerBodyWithPhantoms [] expected body =
|
||||
lowerExprAgainst body expected
|
||||
lowerBodyWithPhantoms phantomViews expected (SLambda params body) =
|
||||
lowerLambdaSpine phantomViews expected params body
|
||||
lowerBodyWithPhantoms phantomViews expected body =
|
||||
lowerExprAgainst body (residualViewExpr phantomViews expected)
|
||||
|
||||
lowerLambdaSpine :: [ViewExpr] -> ViewExpr -> [String] -> TricuAST -> LowerM [String]
|
||||
lowerLambdaSpine phantomViews expected [] body = lowerBodyWithPhantoms phantomViews expected body
|
||||
lowerLambdaSpine [] _ _ _ = pure []
|
||||
lowerLambdaSpine (view : views) expected (param : params) body =
|
||||
withLocalBinder param $ \paramSym -> do
|
||||
declareParam <- declareKnown paramSym view
|
||||
restNodes <- lowerLambdaSpine views expected params body
|
||||
pure (declareParam : restNodes)
|
||||
|
||||
residualViewExpr :: [ViewExpr] -> ViewExpr -> ViewExpr
|
||||
residualViewExpr [] resultView = resultView
|
||||
residualViewExpr args resultView = viewExprFn args resultView
|
||||
|
||||
phantomArgs :: [DefArg] -> [DefArg]
|
||||
phantomArgs [] = []
|
||||
phantomArgs (DefPhantom ty : rest) = DefPhantom ty : phantomArgs rest
|
||||
phantomArgs (_ : rest) = phantomArgs rest
|
||||
|
||||
lowerPhantomArgType :: DefArg -> ViewExpr
|
||||
lowerPhantomArgType (DefPhantom ty) = ty
|
||||
lowerPhantomArgType _ = error "internal check error: expected phantom arg"
|
||||
|
||||
lowerReturnObligation :: Maybe ViewExpr -> LowerM ([ViewExpr], ViewExpr)
|
||||
lowerReturnObligation Nothing = pure ([], viewAnyType)
|
||||
lowerReturnObligation (Just ty) = pure (peelFnObligation ty)
|
||||
|
||||
peelFnObligation :: ViewExpr -> ([ViewExpr], ViewExpr)
|
||||
peelFnObligation ty = case viewExprFnParts ty of
|
||||
Just (args, resultView) ->
|
||||
let (restArgs, finalResult) = peelFnObligation resultView
|
||||
in (args ++ restArgs, finalResult)
|
||||
Nothing -> ([], ty)
|
||||
|
||||
withDefinitionScope :: [DefArg] -> LowerM a -> LowerM a
|
||||
withDefinitionScope args action = do
|
||||
binderEntries <- mapM allocateBinder [ name | DefBinder name _ <- args ]
|
||||
modify $ \st -> st { scopes = Map.fromList binderEntries : scopes st }
|
||||
resultValue <- action
|
||||
modify $ \st -> st { scopes = drop 1 (scopes st) }
|
||||
pure resultValue
|
||||
|
||||
allocateBinder :: String -> LowerM (String, Integer)
|
||||
allocateBinder name = do
|
||||
sym <- freshSym
|
||||
recordDebugName sym name
|
||||
pure (name, sym)
|
||||
|
||||
withLocalBinder :: String -> (Integer -> LowerM a) -> LowerM a
|
||||
withLocalBinder name action = do
|
||||
sym <- freshSym
|
||||
recordDebugName sym name
|
||||
withLocalAlias name sym (action sym)
|
||||
|
||||
withLocalAlias :: String -> Integer -> LowerM a -> LowerM a
|
||||
withLocalAlias name sym action = do
|
||||
modify $ \st -> st { scopes = Map.singleton name sym : scopes st }
|
||||
resultValue <- action
|
||||
modify $ \st -> st { scopes = drop 1 (scopes st) }
|
||||
pure resultValue
|
||||
|
||||
recordKnown :: Integer -> ViewExpr -> LowerM ()
|
||||
recordKnown sym view =
|
||||
modify $ \st -> st { knownNodeViews = Map.insert sym view (knownNodeViews st) }
|
||||
|
||||
recordPayload :: Integer -> T -> LowerM ()
|
||||
recordPayload sym payload =
|
||||
modify $ \st -> st { nodePayloads = Map.insert sym payload (nodePayloads st) }
|
||||
|
||||
payloadFor :: Integer -> LowerM (Maybe T)
|
||||
payloadFor sym = do
|
||||
st <- get
|
||||
pure (Map.lookup sym (nodePayloads st))
|
||||
|
||||
payloadSourceFor :: Integer -> LowerM String
|
||||
payloadSourceFor sym = maybe "t" treeSource <$> payloadFor sym
|
||||
|
||||
knownNodeViewFor :: Integer -> LowerM (Maybe ViewExpr)
|
||||
knownNodeViewFor sym = do
|
||||
st <- get
|
||||
pure (Map.lookup sym (knownNodeViews st))
|
||||
|
||||
recordDebugName :: Integer -> String -> LowerM ()
|
||||
recordDebugName sym label =
|
||||
modify $ \st -> st { debugNames = Map.insertWith keepExisting sym label (debugNames st) }
|
||||
where
|
||||
keepExisting _ old = old
|
||||
|
||||
lowerExpr :: TricuAST -> LowerM (Integer, [String])
|
||||
lowerExpr expr = do
|
||||
(sym, nodes, _) <- lowerExprKnown expr
|
||||
pure (sym, nodes)
|
||||
|
||||
lowerExprAgainst :: TricuAST -> ViewExpr -> LowerM [String]
|
||||
lowerExprAgainst body expected = do
|
||||
(_, nodes, _) <- lowerExprKnownAgainst body expected
|
||||
pure nodes
|
||||
|
||||
lowerExprKnownAgainst :: TricuAST -> ViewExpr -> LowerM (Integer, [String], Maybe ViewExpr)
|
||||
lowerExprKnownAgainst expr expected = case (expr, viewExprAsType expected) of
|
||||
(SApp (SApp (SVar "pair" _) left) right, Just (VTPair leftView rightView)) ->
|
||||
let leftExpr = viewTypeToExpr leftView
|
||||
rightExpr = viewTypeToExpr rightView
|
||||
in lowerUnshadowedConstructor "pair" expr expected $ do
|
||||
(_, leftNodes, _) <- lowerExprKnownAgainst left leftExpr
|
||||
(_, rightNodes, _) <- lowerExprKnownAgainst right rightExpr
|
||||
(sym, nodes) <- declareAndRequireFresh expected
|
||||
pure (sym, leftNodes ++ rightNodes ++ nodes, Just expected)
|
||||
(SApp (SVar "just" _) value, Just (VTMaybe elemView)) ->
|
||||
let elemExpr = viewTypeToExpr elemView
|
||||
in lowerUnshadowedConstructor "just" expr expected $ do
|
||||
(_, valueNodes, _) <- lowerExprKnownAgainst value elemExpr
|
||||
(sym, nodes) <- declareAndRequireFresh expected
|
||||
pure (sym, valueNodes ++ nodes, Just expected)
|
||||
(SVar "nothing" _, Just (VTMaybe _)) ->
|
||||
lowerUnshadowedConstructor "nothing" expr expected $ do
|
||||
(sym, nodes) <- declareAndRequireFresh expected
|
||||
pure (sym, nodes, Just expected)
|
||||
(SApp (SApp (SVar "ok" _) value) rest, Just (VTResult _ okView)) ->
|
||||
lowerUnshadowedConstructor "ok" expr expected $
|
||||
lowerResultConstructor expected (viewTypeToExpr okView) value rest
|
||||
(SApp (SApp (SVar "err" _) value) rest, Just (VTResult errView _)) ->
|
||||
lowerUnshadowedConstructor "err" expr expected $
|
||||
lowerResultConstructor expected (viewTypeToExpr errView) value rest
|
||||
(SApp (SLambda [name] body) value, _) -> do
|
||||
(valueSym, valueNodes, _) <- lowerExprKnown value
|
||||
bodyResult <- withLocalAlias name valueSym (lowerExprKnownAgainst body expected)
|
||||
let (bodySym, bodyNodes, bodyKnown) = bodyResult
|
||||
pure (bodySym, valueNodes ++ bodyNodes, bodyKnown)
|
||||
(SList items, Just (VTList elemView)) -> do
|
||||
let elemExpr = viewTypeToExpr elemView
|
||||
lowered <- mapM (`lowerExprKnownAgainst` elemExpr) items
|
||||
let itemNodes = concat [ nodes | (_, nodes, _) <- lowered ]
|
||||
(sym, nodes) <- declareAndRequireFresh expected
|
||||
pure (sym, itemNodes ++ nodes, Just expected)
|
||||
(SLambda _ _, _) ->
|
||||
case peelFnObligation expected of
|
||||
([], _) -> lowerExprKnownAndRequire expr expected
|
||||
(argViews, resultView) -> lowerLambdaAgainst argViews resultView expr
|
||||
_ -> lowerExprKnownAndRequire expr expected
|
||||
|
||||
lowerUnshadowedConstructor :: String -> TricuAST -> ViewExpr -> LowerM (Integer, [String], Maybe ViewExpr) -> LowerM (Integer, [String], Maybe ViewExpr)
|
||||
lowerUnshadowedConstructor name fallback expected lowerCtor = do
|
||||
ctorIsUnbound <- nameIsUnbound name
|
||||
if ctorIsUnbound
|
||||
then lowerCtor
|
||||
else lowerExprKnownAndRequire fallback expected
|
||||
|
||||
lowerResultConstructor :: ViewExpr -> ViewExpr -> TricuAST -> TricuAST -> LowerM (Integer, [String], Maybe ViewExpr)
|
||||
lowerResultConstructor expected valueView value rest = do
|
||||
(_, valueNodes, _) <- lowerExprKnownAgainst value valueView
|
||||
(_, restNodes, _) <- lowerExprKnown rest
|
||||
(sym, nodes) <- declareAndRequireFresh expected
|
||||
pure (sym, valueNodes ++ restNodes ++ nodes, Just expected)
|
||||
|
||||
lowerExprKnownAndRequire :: TricuAST -> ViewExpr -> LowerM (Integer, [String], Maybe ViewExpr)
|
||||
lowerExprKnownAndRequire body expected = do
|
||||
(bodySym, bodyNodes, known) <- lowerExprKnown body
|
||||
requireNode <- typedRequireNode bodySym expected
|
||||
pure (bodySym, bodyNodes ++ [requireNode], known)
|
||||
|
||||
lowerLambdaAgainst :: [ViewExpr] -> ViewExpr -> TricuAST -> LowerM (Integer, [String], Maybe ViewExpr)
|
||||
lowerLambdaAgainst argViews resultView (SLambda params body) = do
|
||||
nodes <- lowerLambdaSpine argViews resultView params body
|
||||
sym <- freshSym
|
||||
let fnView = residualViewExpr argViews resultView
|
||||
declareNode <- declareKnown sym fnView
|
||||
pure (sym, nodes ++ [declareNode], Just fnView)
|
||||
lowerLambdaAgainst argViews resultView body =
|
||||
lowerExprKnownAndRequire body (residualViewExpr argViews resultView)
|
||||
|
||||
lowerExprKnown :: TricuAST -> LowerM (Integer, [String], Maybe ViewExpr)
|
||||
lowerExprKnown (SVar name _) = do
|
||||
sym <- symbolForName name
|
||||
known <- knownNodeViewFor sym
|
||||
pure (sym, [], known)
|
||||
lowerExprKnown (SStr s) = do
|
||||
let view = VEName "String"
|
||||
(sym, nodes) <- declareKnownFreshWithPayload view (ofString s)
|
||||
recordDebugName sym "string literal"
|
||||
pure (sym, nodes, Just view)
|
||||
lowerExprKnown (SInt n)
|
||||
| n >= 0 && n <= 255 = do
|
||||
let view = VEName "Byte"
|
||||
(sym, nodes) <- declareKnownFreshWithPayload view (ofNumber n)
|
||||
recordDebugName sym "byte literal"
|
||||
pure (sym, nodes, Just view)
|
||||
| otherwise = do
|
||||
sym <- freshSym
|
||||
pure (sym, [], Nothing)
|
||||
lowerExprKnown TLeaf = do
|
||||
let view = VEName "Unit"
|
||||
(sym, nodes) <- declareKnownFreshWithPayload view Leaf
|
||||
recordDebugName sym "unit literal"
|
||||
pure (sym, nodes, Just view)
|
||||
lowerExprKnown (SList items) = do
|
||||
(sym, nodes, view, _) <- lowerListLiteral items
|
||||
pure (sym, nodes, Just view)
|
||||
lowerExprKnown (SApp (SLambda [name] body) value) = do
|
||||
(valueSym, valueNodes, known) <- lowerExprKnown value
|
||||
bodyResult <- withLocalAlias name valueSym (lowerExprKnown body)
|
||||
let (bodySym, bodyNodes, bodyKnown) = bodyResult
|
||||
pure (bodySym, valueNodes ++ bodyNodes, bodyKnown)
|
||||
lowerExprKnown (SApp func arg) = do
|
||||
(funcSym, funcNodes, funcKnown) <- lowerExprKnown func
|
||||
(argSym, argNodes, _) <- lowerApplicationArgument funcKnown arg
|
||||
outSym <- freshSym
|
||||
recordDebugName outSym (applicationDebugLabel func)
|
||||
funcPayload <- payloadFor funcSym
|
||||
argPayload <- payloadFor argSym
|
||||
case (funcPayload, argPayload) of
|
||||
(Just f, Just a) -> recordPayload outSym (apply f a)
|
||||
_ -> pure ()
|
||||
applyPayload <- payloadSourceFor outSym
|
||||
let applyNode = "typedApply " ++ show outSym ++ " " ++ show funcSym ++ " " ++ show argSym ++ " " ++ applyPayload
|
||||
outKnown = applicationResultView funcKnown
|
||||
mapM_ (recordKnown outSym) outKnown
|
||||
pure (outSym, funcNodes ++ argNodes ++ [applyNode], outKnown)
|
||||
lowerExprKnown (SLambda params body) = do
|
||||
nodes <- lowerUnannotatedLambda params body
|
||||
sym <- freshSym
|
||||
pure (sym, nodes, Nothing)
|
||||
lowerExprKnown _ = do
|
||||
sym <- freshSym
|
||||
pure (sym, [], Nothing)
|
||||
|
||||
lowerListLiteral :: [TricuAST] -> LowerM (Integer, [String], ViewExpr, [Integer])
|
||||
lowerListLiteral items = do
|
||||
lowered <- mapM lowerExprKnown items
|
||||
let itemSyms = [ itemSym | (itemSym, _, _) <- lowered ]
|
||||
itemNodes = concat [ nodes | (_, nodes, _) <- lowered ]
|
||||
view = listLiteralView [ known | (_, _, known) <- lowered ]
|
||||
itemPayloads <- mapM payloadFor itemSyms
|
||||
let mPayload = ofList <$> sequence itemPayloads
|
||||
(sym, declareNodes) <- case mPayload of
|
||||
Just payload -> declareKnownFreshWithPayload view payload
|
||||
Nothing -> declareKnownFresh view
|
||||
pure (sym, itemNodes ++ declareNodes, view, itemSyms)
|
||||
|
||||
lowerApplicationArgument :: Maybe ViewExpr -> TricuAST -> LowerM (Integer, [String], Maybe ViewExpr)
|
||||
lowerApplicationArgument (Just fnView) arg =
|
||||
case viewExprFnParts fnView of
|
||||
Just (argView : _, _) -> lowerExprKnownAgainst arg argView
|
||||
_ -> lowerExprKnown arg
|
||||
lowerApplicationArgument _ arg =
|
||||
lowerExprKnown arg
|
||||
|
||||
applicationDebugLabel :: TricuAST -> String
|
||||
applicationDebugLabel func =
|
||||
case applicationHeadName func of
|
||||
Just name -> name ++ " application result"
|
||||
Nothing -> "application result"
|
||||
|
||||
applicationHeadName :: TricuAST -> Maybe String
|
||||
applicationHeadName (SVar name _) = Just name
|
||||
applicationHeadName (SApp func _) = applicationHeadName func
|
||||
applicationHeadName _ = Nothing
|
||||
|
||||
applicationResultView :: Maybe ViewExpr -> Maybe ViewExpr
|
||||
applicationResultView (Just fnView) = case viewExprFnParts fnView of
|
||||
Just (_ : restArgs, resultView) ->
|
||||
Just $ case restArgs of
|
||||
[] -> resultView
|
||||
_ -> viewExprFn restArgs resultView
|
||||
_ -> Nothing
|
||||
applicationResultView _ = Nothing
|
||||
|
||||
listLiteralView :: [Maybe ViewExpr] -> ViewExpr
|
||||
listLiteralView [] = viewExprList viewAnyType
|
||||
listLiteralView (Just firstView : rest)
|
||||
| all (== Just firstView) rest = viewExprList firstView
|
||||
listLiteralView _ = viewExprList viewAnyType
|
||||
|
||||
lowerUnannotatedLambda :: [String] -> TricuAST -> LowerM [String]
|
||||
lowerUnannotatedLambda [] body = do
|
||||
(_, nodes) <- lowerExpr body
|
||||
pure nodes
|
||||
lowerUnannotatedLambda (param : params) body =
|
||||
withLocalBinder param $ \paramSym -> do
|
||||
declareParam <- declareKnown paramSym viewAnyType
|
||||
restNodes <- lowerUnannotatedLambda params body
|
||||
pure (declareParam : restNodes)
|
||||
|
||||
symbolForTop :: String -> LowerM Integer
|
||||
symbolForTop name = do
|
||||
st <- get
|
||||
case Map.lookup name (topSyms st) of
|
||||
Just sym -> pure sym
|
||||
Nothing -> liftEither (Left $ "internal check error: missing top-level symbol: " ++ name)
|
||||
|
||||
symbolForLocal :: String -> LowerM Integer
|
||||
symbolForLocal name = do
|
||||
st <- get
|
||||
case lookupInScopes name (scopes st) of
|
||||
Just sym -> pure sym
|
||||
Nothing -> liftEither (Left $ "internal check error: missing local symbol: " ++ name)
|
||||
|
||||
symbolForName :: String -> LowerM Integer
|
||||
symbolForName name = do
|
||||
st <- get
|
||||
case lookupInScopes name (scopes st) of
|
||||
Just sym -> pure sym
|
||||
Nothing -> case Map.lookup name (topSyms st) of
|
||||
Just sym -> pure sym
|
||||
Nothing -> symbolForExternal name
|
||||
|
||||
symbolForExternal :: String -> LowerM Integer
|
||||
symbolForExternal name = do
|
||||
st <- get
|
||||
case Map.lookup name (externSyms st) of
|
||||
Just sym -> pure sym
|
||||
Nothing -> do
|
||||
sym <- freshSym
|
||||
recordDebugName sym ("external " ++ name)
|
||||
modify $ \st' -> st' { externSyms = Map.insert name sym (externSyms st') }
|
||||
pure sym
|
||||
|
||||
nameIsUnbound :: String -> LowerM Bool
|
||||
nameIsUnbound name = do
|
||||
st <- get
|
||||
pure $ case lookupInScopes name (scopes st) of
|
||||
Just _ -> False
|
||||
Nothing -> Map.notMember name (topSyms st)
|
||||
|
||||
lookupInScopes :: String -> [Map.Map String Integer] -> Maybe Integer
|
||||
lookupInScopes _ [] = Nothing
|
||||
lookupInScopes name (scope : rest) =
|
||||
case Map.lookup name scope of
|
||||
Just sym -> Just sym
|
||||
Nothing -> lookupInScopes name rest
|
||||
|
||||
freshSym :: LowerM Integer
|
||||
freshSym = do
|
||||
st <- get
|
||||
let sym = nextSym st
|
||||
put st { nextSym = sym + 1 }
|
||||
pure sym
|
||||
|
||||
isDefinition :: TricuAST -> Bool
|
||||
isDefinition SDef {} = True
|
||||
isDefinition SDefAnn {} = True
|
||||
isDefinition _ = False
|
||||
|
||||
definitionName :: TricuAST -> String
|
||||
definitionName (SDef name _ _) = name
|
||||
definitionName (SDefAnn name _ _ _) = name
|
||||
definitionName _ = error "definitionName: expected top-level definition"
|
||||
|
||||
liftEither :: Either String a -> LowerM a
|
||||
liftEither value = StateT $ \st -> case value of
|
||||
Left err -> Left err
|
||||
Right resultValue -> Right (resultValue, st)
|
||||
|
||||
lowerArgView :: DefArg -> LowerM String
|
||||
lowerArgView (DefBinder _ Nothing) = pure "viewAny"
|
||||
lowerArgView (DefBinder _ (Just ty)) = liftEither (lowerViewExpr ty)
|
||||
lowerArgView (DefPhantom ty) = liftEither (lowerViewExpr ty)
|
||||
|
||||
viewTypeToExpr :: ViewType -> ViewExpr
|
||||
viewTypeToExpr view = case view of
|
||||
VTName name -> VEName name
|
||||
VTRef n -> VEApp (VEName "Ref") (VEInt n)
|
||||
VTRefText s -> VEApp (VEName "Ref") (VEString s)
|
||||
VTList item -> VEApp (VEName "List") (viewTypeToExpr item)
|
||||
VTMaybe item -> VEApp (VEName "Maybe") (viewTypeToExpr item)
|
||||
VTPair left right -> VEApp (VEApp (VEName "Pair") (viewTypeToExpr left)) (viewTypeToExpr right)
|
||||
VTResult err ok -> VEApp (VEApp (VEName "Result") (viewTypeToExpr err)) (viewTypeToExpr ok)
|
||||
VTGuarded base guard -> VEApp (VEApp (VEName "viewGuarded") (viewTypeToExpr base)) (VERaw (treeSource guard))
|
||||
VTFn args resultView -> viewExprFn (map viewTypeToExpr args) (viewTypeToExpr resultView)
|
||||
|
||||
viewExprFn :: [ViewExpr] -> ViewExpr -> ViewExpr
|
||||
viewExprFn args resultView = VEApp (VEApp (VEName "Fn") (VEList args)) resultView
|
||||
|
||||
viewExprList :: ViewExpr -> ViewExpr
|
||||
viewExprList = VEApp (VEName "List")
|
||||
|
||||
viewExprFnParts :: ViewExpr -> Maybe ([ViewExpr], ViewExpr)
|
||||
viewExprFnParts (VEApp (VEApp (VEName "Fn") (VEList args)) resultView) = Just (args, resultView)
|
||||
viewExprFnParts _ = Nothing
|
||||
|
||||
viewExprAsType :: ViewExpr -> Maybe ViewType
|
||||
viewExprAsType view = case view of
|
||||
VEName name -> Just (VTName name)
|
||||
VEApp (VEName "Ref") (VEInt n) -> Just (VTRef n)
|
||||
VEApp (VEName "Ref") (VEString s) -> Just (VTRefText s)
|
||||
VEApp (VEName "List") item -> VTList <$> viewExprAsType item
|
||||
VEApp (VEName "Maybe") item -> VTMaybe <$> viewExprAsType item
|
||||
VEApp (VEApp (VEName "Pair") left) right -> VTPair <$> viewExprAsType left <*> viewExprAsType right
|
||||
VEApp (VEApp (VEName "Result") err) ok -> VTResult <$> viewExprAsType err <*> viewExprAsType ok
|
||||
VEApp (VEApp (VEName "Fn") (VEList args)) resultView -> VTFn <$> mapM viewExprAsType args <*> viewExprAsType resultView
|
||||
_ -> Nothing
|
||||
|
||||
lowerViewExpr :: ViewExpr -> Either String String
|
||||
lowerViewExpr ty = case ty of
|
||||
VEName "Any" -> Right "viewAny"
|
||||
VEName "Bool" -> Right "viewBool"
|
||||
VEName "String" -> Right "viewString"
|
||||
VEName "Byte" -> Right "viewByte"
|
||||
VEName "Unit" -> Right "viewUnit"
|
||||
VEName name -> Right name
|
||||
VEInt n -> Right (show n)
|
||||
VEString s -> Right (show s)
|
||||
VEList items -> do
|
||||
itemExprs <- mapM lowerViewExpr items
|
||||
Right $ "[" ++ unwords (map parens itemExprs) ++ "]"
|
||||
VEApp (VEName "Ref") (VEInt n) -> Right $ "viewRef " ++ show n
|
||||
VEApp (VEName "Ref") (VEString s) -> Right $ "viewRef " ++ show s
|
||||
VEApp (VEName "List") elemView -> do
|
||||
elemExpr <- lowerViewExpr elemView
|
||||
Right $ "viewList " ++ parens elemExpr
|
||||
VEApp (VEName "Maybe") elemView -> do
|
||||
elemExpr <- lowerViewExpr elemView
|
||||
Right $ "viewMaybe " ++ parens elemExpr
|
||||
VEApp (VEApp (VEName "Pair") left) right -> do
|
||||
l <- lowerViewExpr left
|
||||
r <- lowerViewExpr right
|
||||
Right $ "viewPair " ++ parens l ++ " " ++ parens r
|
||||
VEApp (VEApp (VEName "Result") err) ok -> do
|
||||
e <- lowerViewExpr err
|
||||
a <- lowerViewExpr ok
|
||||
Right $ "viewResult " ++ parens e ++ " " ++ parens a
|
||||
VEApp (VEApp (VEName "Fn") (VEList args)) resultView -> do
|
||||
as <- mapM lowerViewExpr args
|
||||
r <- lowerViewExpr resultView
|
||||
Right $ "viewFn [" ++ unwords (map parens as) ++ "] " ++ parens r
|
||||
VEApp func arg -> do
|
||||
f <- lowerViewExpr func
|
||||
a <- lowerViewExpr arg
|
||||
Right $ parens f ++ " " ++ parens a
|
||||
VERaw raw -> Right raw
|
||||
|
||||
treeSource :: T -> String
|
||||
treeSource Leaf = "t"
|
||||
treeSource (Stem x) = "(t " ++ treeSource x ++ ")"
|
||||
treeSource (Fork x y) = "(t " ++ treeSource x ++ " " ++ treeSource y ++ ")"
|
||||
|
||||
parens :: String -> String
|
||||
parens s = "(" ++ s ++ ")"
|
||||
409
src/Check/IO.hs
Normal file
409
src/Check/IO.hs
Normal file
@@ -0,0 +1,409 @@
|
||||
module Check.IO
|
||||
( instrumentIOContinuations
|
||||
) where
|
||||
|
||||
import Control.Monad.State.Strict
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Check.Core (lowerViewExpr)
|
||||
import Parser (parseTricu)
|
||||
import Research
|
||||
|
||||
viewAnyType :: ViewExpr
|
||||
viewAnyType = VEName "Any"
|
||||
|
||||
argType :: DefArg -> ViewExpr
|
||||
argType (DefBinder _ Nothing) = viewAnyType
|
||||
argType (DefBinder _ (Just ty)) = ty
|
||||
argType (DefPhantom ty) = ty
|
||||
|
||||
declaredDefinitionView :: [DefArg] -> Maybe ViewExpr -> ViewExpr
|
||||
declaredDefinitionView args ret =
|
||||
case map argType args of
|
||||
[] -> resultType
|
||||
views -> viewExprFn views resultType
|
||||
where
|
||||
resultType = maybe viewAnyType id ret
|
||||
|
||||
viewExprFn :: [ViewExpr] -> ViewExpr -> ViewExpr
|
||||
viewExprFn args resultView = VEApp (VEApp (VEName "Fn") (VEList args)) resultView
|
||||
|
||||
viewExprList :: ViewExpr -> ViewExpr
|
||||
viewExprList = VEApp (VEName "List")
|
||||
|
||||
viewExprFnParts :: ViewExpr -> Maybe ([ViewExpr], ViewExpr)
|
||||
viewExprFnParts (VEApp (VEApp (VEName "Fn") (VEList args)) resultView) = Just (args, resultView)
|
||||
viewExprFnParts _ = Nothing
|
||||
|
||||
viewExprAsType :: ViewExpr -> Maybe ViewType
|
||||
viewExprAsType view = case view of
|
||||
VEName name -> Just (VTName name)
|
||||
VEApp (VEName "Ref") (VEInt n) -> Just (VTRef n)
|
||||
VEApp (VEName "Ref") (VEString st) -> Just (VTRefText st)
|
||||
VEApp (VEName "List") item -> VTList <$> viewExprAsType item
|
||||
VEApp (VEName "Maybe") item -> VTMaybe <$> viewExprAsType item
|
||||
VEApp (VEApp (VEName "Pair") left) right -> VTPair <$> viewExprAsType left <*> viewExprAsType right
|
||||
VEApp (VEApp (VEName "Result") err) ok -> VTResult <$> viewExprAsType err <*> viewExprAsType ok
|
||||
VEApp (VEApp (VEName "Fn") (VEList args)) resultView -> VTFn <$> mapM viewExprAsType args <*> viewExprAsType resultView
|
||||
_ -> Nothing
|
||||
|
||||
viewTypeToExpr :: ViewType -> ViewExpr
|
||||
viewTypeToExpr view = case view of
|
||||
VTName name -> VEName name
|
||||
VTRef n -> VEApp (VEName "Ref") (VEInt n)
|
||||
VTRefText st -> VEApp (VEName "Ref") (VEString st)
|
||||
VTList item -> VEApp (VEName "List") (viewTypeToExpr item)
|
||||
VTMaybe item -> VEApp (VEName "Maybe") (viewTypeToExpr item)
|
||||
VTPair left right -> VEApp (VEApp (VEName "Pair") (viewTypeToExpr left)) (viewTypeToExpr right)
|
||||
VTResult err ok -> VEApp (VEApp (VEName "Result") (viewTypeToExpr err)) (viewTypeToExpr ok)
|
||||
VTGuarded base guard -> VEApp (VEApp (VEName "viewGuarded") (viewTypeToExpr base)) (VERaw (treeSource guard))
|
||||
VTFn args resultView -> viewExprFn (map viewTypeToExpr args) (viewTypeToExpr resultView)
|
||||
|
||||
treeSource :: T -> String
|
||||
treeSource Leaf = "t"
|
||||
treeSource (Stem x) = "(t " ++ treeSource x ++ ")"
|
||||
treeSource (Fork x y) = "(t " ++ treeSource x ++ " " ++ treeSource y ++ ")"
|
||||
|
||||
applicationResultView :: Maybe ViewExpr -> Maybe ViewExpr
|
||||
applicationResultView (Just fnView) = case viewExprFnParts fnView of
|
||||
Just (_ : restArgs, resultView) ->
|
||||
Just $ case restArgs of
|
||||
[] -> resultView
|
||||
_ -> viewExprFn restArgs resultView
|
||||
_ -> Nothing
|
||||
applicationResultView _ = Nothing
|
||||
|
||||
-- Instrument source-level IO continuations so pure calls to annotated
|
||||
-- functions can run the already-portable checked-exec protocol at runtime.
|
||||
-- This is deliberately a lowering pass: it builds checked boundaries once from
|
||||
-- source annotations, then ordinary IO execution only evaluates runChecked.
|
||||
instrumentIOContinuations :: [TricuAST] -> Either String [TricuAST]
|
||||
instrumentIOContinuations asts = mapM transformTop asts
|
||||
where
|
||||
contracts = Map.fromList
|
||||
[ (name, (args, ret, body))
|
||||
| SDefAnn name args ret body <- asts
|
||||
, all isRuntimeBinder args
|
||||
]
|
||||
|
||||
isRuntimeBinder DefBinder {} = True
|
||||
isRuntimeBinder DefPhantom {} = False
|
||||
|
||||
transformTop (SDef name params body) = SDef name params <$> transformExpr body
|
||||
transformTop (SDefAnn name args ret body) = SDefAnn name args ret <$> transformExpr body
|
||||
transformTop other = transformExpr other
|
||||
|
||||
transformExpr expr = case expr of
|
||||
SApp (SVar "io" h) action -> SApp (SVar "io" h) <$> transformIOAction action
|
||||
SApp f a -> SApp <$> transformExpr f <*> transformExpr a
|
||||
SLambda params body -> SLambda params <$> transformExpr body
|
||||
TStem x -> TStem <$> transformExpr x
|
||||
TFork x y -> TFork <$> transformExpr x <*> transformExpr y
|
||||
_ -> pure expr
|
||||
|
||||
transformIOAction action = case action of
|
||||
SApp (SVar "pure" _) value ->
|
||||
case checkedPureActionFor value of
|
||||
Just checked -> parseOne checked
|
||||
Nothing -> SApp (SVar "pure" Nothing) <$> transformExpr value
|
||||
SApp (SApp (SVar "bind" h) left) (SLambda params body) ->
|
||||
SApp <$> (SApp (SVar "bind" h) <$> transformIOAction left) <*> (SLambda params <$> transformIOAction body)
|
||||
SApp f a -> SApp <$> transformIOAction f <*> transformIOAction a
|
||||
SLambda params body -> SLambda params <$> transformIOAction body
|
||||
_ -> transformExpr action
|
||||
|
||||
checkedPureActionFor value =
|
||||
case contractedApplication value of
|
||||
Just (name, defArgs, ret, body, callArgs) ->
|
||||
Just (checkedPureApplicationActionSource contracts name defArgs ret body callArgs)
|
||||
Nothing ->
|
||||
if mentionsContractedName contracts value
|
||||
then Just (checkedPureValueActionSource contracts value)
|
||||
else Nothing
|
||||
where
|
||||
contractedApplication valueExpr = do
|
||||
(headExpr, callArgs) <- applicationSpine valueExpr
|
||||
name <- case headExpr of
|
||||
SVar n _ -> Just n
|
||||
_ -> Nothing
|
||||
(defArgs, ret, body) <- Map.lookup name contracts
|
||||
if length callArgs == length defArgs
|
||||
then Just (name, defArgs, ret, body, callArgs)
|
||||
else Nothing
|
||||
|
||||
parseOne source = case parseTricu source of
|
||||
[expr] -> Right expr
|
||||
_ -> Left $ "internal check error: could not parse generated checked IO action: " ++ source
|
||||
|
||||
applicationSpine :: TricuAST -> Maybe (TricuAST, [TricuAST])
|
||||
applicationSpine expr = Just (go expr [])
|
||||
where
|
||||
go (SApp f a) args = go f (a : args)
|
||||
go headExpr args = (headExpr, args)
|
||||
|
||||
checkedPureApplicationActionSource :: RuntimeContracts -> String -> [DefArg] -> Maybe ViewExpr -> TricuAST -> [TricuAST] -> String
|
||||
checkedPureApplicationActionSource contracts name defArgs ret body callArgs =
|
||||
checkedProgramAction boundaryProgram ("(_ runtimeEnv : " ++ bodyAction ++ ")")
|
||||
where
|
||||
argViews = map argType defArgs
|
||||
retView = maybe viewAnyType id ret
|
||||
fnView = "viewFn [" ++ unwords (map (parens . unsafeLowerViewExpr) argViews) ++ "] " ++ parens (unsafeLowerViewExpr retView)
|
||||
boundaryRoot = fromIntegral (length callArgs * 2) :: Integer
|
||||
boundaryProgram = "typedProgram " ++ show boundaryRoot ++ " [" ++ unwords (map parens boundaryNodes) ++ "]"
|
||||
boundaryNodes = functionNode : concat argApplyNodes
|
||||
functionNode = "typedValue 0 " ++ parens fnView ++ " " ++ parens (astSource (SVar name Nothing))
|
||||
argApplyNodes =
|
||||
[ let argSym = fromIntegral (idx * 2 - 1) :: Integer
|
||||
outSym = fromIntegral (idx * 2) :: Integer
|
||||
calleeSym = if idx == 1 then 0 else fromIntegral ((idx - 1) * 2)
|
||||
argView = argRuntimeViewSource view
|
||||
prefixArgs = take idx callArgs
|
||||
payload = astSource (foldl SApp (SVar name Nothing) prefixArgs)
|
||||
in [ "typedValue " ++ show argSym ++ " " ++ parens argView ++ " " ++ parens (astSource arg)
|
||||
, "typedApply " ++ show outSym ++ " " ++ show calleeSym ++ " " ++ show argSym ++ " " ++ parens payload
|
||||
]
|
||||
| (idx, (view, arg)) <- zip [1 :: Int ..] (zip argViews callArgs)
|
||||
]
|
||||
(bodyRoot, bodyNodes) = runtimeBodyProgramNodes contracts defArgs retView body callArgs
|
||||
bodyProgram = "typedProgram " ++ show bodyRoot ++ " [" ++ unwords (map parens bodyNodes) ++ "]"
|
||||
bodyAction = checkedProgramAction bodyProgram "(value runtimeEnv : pure value)"
|
||||
|
||||
type RuntimeContracts = Map.Map String ([DefArg], Maybe ViewExpr, TricuAST)
|
||||
|
||||
mentionsContractedName :: RuntimeContracts -> TricuAST -> Bool
|
||||
mentionsContractedName contracts expr = case expr of
|
||||
SVar name _ -> Map.member name contracts
|
||||
SApp f a -> mentionsContractedName contracts f || mentionsContractedName contracts a
|
||||
SLambda _ body -> mentionsContractedName contracts body
|
||||
SList items -> any (mentionsContractedName contracts) items
|
||||
TStem x -> mentionsContractedName contracts x
|
||||
TFork x y -> mentionsContractedName contracts x || mentionsContractedName contracts y
|
||||
SDef _ _ body -> mentionsContractedName contracts body
|
||||
SDefAnn _ _ _ body -> mentionsContractedName contracts body
|
||||
_ -> False
|
||||
|
||||
checkedPureValueActionSource :: RuntimeContracts -> TricuAST -> String
|
||||
checkedPureValueActionSource contracts value =
|
||||
checkedProgramAction program "(value runtimeEnv : pure value)"
|
||||
where
|
||||
(rootSym, nodes) = runtimeExpressionProgramNodes contracts value viewAnyType
|
||||
program = "typedProgram " ++ show rootSym ++ " [" ++ unwords (map parens nodes) ++ "]"
|
||||
|
||||
checkedProgramAction :: String -> String -> String
|
||||
checkedProgramAction program okCase =
|
||||
"matchResult " ++
|
||||
"(diag env : pure (renderDiagnostic diag)) " ++
|
||||
"(exec env : matchResult " ++
|
||||
"(runtimeDiag runtimeEnv : pure (renderDiagnostic runtimeDiag)) " ++
|
||||
okCase ++ " " ++
|
||||
"(runChecked exec)) " ++
|
||||
"(checkTypedProgramWith policyStrict " ++ parens program ++ ")"
|
||||
|
||||
runtimeExpressionProgramNodes :: RuntimeContracts -> TricuAST -> ViewExpr -> (Integer, [String])
|
||||
runtimeExpressionProgramNodes contracts expr expected =
|
||||
let (rootSym, nodes, _) = runRuntimeLower 0 Map.empty Map.empty Map.empty contracts (lowerRuntimeExprAgainst expr expected)
|
||||
in (rootSym, nodes)
|
||||
|
||||
runtimeBodyProgramNodes :: RuntimeContracts -> [DefArg] -> ViewExpr -> TricuAST -> [TricuAST] -> (Integer, [String])
|
||||
runtimeBodyProgramNodes contracts defArgs retView body callArgs =
|
||||
let binders = [ (idx, name, maybe viewAnyType id mView, arg)
|
||||
| (idx, (DefBinder name mView, arg)) <- zip [0 :: Integer ..] (zip defArgs callArgs)
|
||||
]
|
||||
initialNext = fromIntegral (length binders)
|
||||
initialKnown = Map.fromList [ (idx, view) | (idx, _, view, _) <- binders ]
|
||||
subst = Map.fromList [ (name, arg) | (_, name, _, arg) <- binders ]
|
||||
symbols = Map.fromList [ (name, idx) | (idx, name, _, _) <- binders ]
|
||||
argNodes = concatMap argBoundaryNodes binders
|
||||
(rootSym, bodyNodes, _) = runRuntimeLower initialNext initialKnown subst symbols contracts (lowerRuntimeExpr body)
|
||||
resultRequire = "typedRequire " ++ show rootSym ++ " " ++ parens (unsafeLowerViewExpr retView) ++ " " ++ parens (astSource (substAst subst body))
|
||||
in (rootSym, argNodes ++ bodyNodes ++ [resultRequire])
|
||||
where
|
||||
argBoundaryNodes (idx, _name, view, arg) =
|
||||
[ "typedValue " ++ show idx ++ " " ++ parens (argRuntimeViewSource view) ++ " " ++ parens (astSource arg)
|
||||
, "typedRequire " ++ show idx ++ " " ++ parens (unsafeLowerViewExpr view) ++ " " ++ parens (astSource arg)
|
||||
]
|
||||
|
||||
data RuntimeLower = RuntimeLower
|
||||
{ runtimeNext :: Integer
|
||||
, runtimeKnown :: Map.Map Integer ViewExpr
|
||||
, runtimeSubst :: Map.Map String TricuAST
|
||||
, runtimeSymbols :: Map.Map String Integer
|
||||
, runtimeContracts :: RuntimeContracts
|
||||
}
|
||||
|
||||
type RuntimeM a = State RuntimeLower a
|
||||
|
||||
runRuntimeLower :: Integer -> Map.Map Integer ViewExpr -> Map.Map String TricuAST -> Map.Map String Integer -> RuntimeContracts -> RuntimeM (Integer, [String], Maybe ViewExpr) -> (Integer, [String], Maybe ViewExpr)
|
||||
runRuntimeLower next known subst symbols contracts action = evalState action RuntimeLower
|
||||
{ runtimeNext = next
|
||||
, runtimeKnown = known
|
||||
, runtimeSubst = subst
|
||||
, runtimeSymbols = symbols
|
||||
, runtimeContracts = contracts
|
||||
}
|
||||
|
||||
freshRuntimeSym :: RuntimeM Integer
|
||||
freshRuntimeSym = do
|
||||
st <- get
|
||||
let sym = runtimeNext st
|
||||
put st { runtimeNext = sym + 1 }
|
||||
pure sym
|
||||
|
||||
runtimeKnownFor :: Integer -> RuntimeM (Maybe ViewExpr)
|
||||
runtimeKnownFor sym = gets (Map.lookup sym . runtimeKnown)
|
||||
|
||||
recordRuntimeKnown :: Integer -> ViewExpr -> RuntimeM ()
|
||||
recordRuntimeKnown sym view = modify $ \st -> st { runtimeKnown = Map.insert sym view (runtimeKnown st) }
|
||||
|
||||
lowerRuntimeExpr :: TricuAST -> RuntimeM (Integer, [String], Maybe ViewExpr)
|
||||
lowerRuntimeExpr expr = case expr of
|
||||
SVar name _ -> do
|
||||
symbols <- gets runtimeSymbols
|
||||
case Map.lookup name symbols of
|
||||
Just sym -> do
|
||||
known <- runtimeKnownFor sym
|
||||
pure (sym, [], known)
|
||||
Nothing -> do
|
||||
contracts <- gets runtimeContracts
|
||||
sym <- freshRuntimeSym
|
||||
case Map.lookup name contracts of
|
||||
Just (defArgs, ret, _) -> do
|
||||
let view = declaredDefinitionView defArgs ret
|
||||
viewSource = unsafeLowerViewExpr view
|
||||
recordRuntimeKnown sym view
|
||||
pure (sym, ["typedValue " ++ show sym ++ " " ++ parens viewSource ++ " " ++ parens (astSource expr)], Just view)
|
||||
Nothing ->
|
||||
pure (sym, ["typedValue " ++ show sym ++ " viewAny " ++ parens (astSource expr)], Just viewAnyType)
|
||||
SStr s -> do
|
||||
sym <- freshRuntimeSym
|
||||
let view = VEName "String"
|
||||
recordRuntimeKnown sym view
|
||||
pure (sym, ["typedValue " ++ show sym ++ " viewString " ++ parens (astSource (SStr s))], Just view)
|
||||
SInt n | n >= 0 && n <= 255 -> do
|
||||
sym <- freshRuntimeSym
|
||||
let view = VEName "Byte"
|
||||
recordRuntimeKnown sym view
|
||||
pure (sym, ["typedValue " ++ show sym ++ " viewByte " ++ show n], Just view)
|
||||
TLeaf -> do
|
||||
sym <- freshRuntimeSym
|
||||
let view = VEName "Unit"
|
||||
recordRuntimeKnown sym view
|
||||
pure (sym, ["typedValue " ++ show sym ++ " viewUnit t"], Just view)
|
||||
SList items -> do
|
||||
lowered <- mapM lowerRuntimeExpr items
|
||||
sym <- freshRuntimeSym
|
||||
let view = viewExprList viewAnyType
|
||||
recordRuntimeKnown sym view
|
||||
subst <- gets runtimeSubst
|
||||
let payload = astSource (substAst subst expr)
|
||||
pure (sym, concat [ ns | (_, ns, _) <- lowered ] ++ ["typedValue " ++ show sym ++ " " ++ parens (unsafeLowerViewExpr view) ++ " " ++ parens payload], Just view)
|
||||
SApp f a -> lowerRuntimeApplication f a expr
|
||||
_ -> do
|
||||
sym <- freshRuntimeSym
|
||||
subst <- gets runtimeSubst
|
||||
pure (sym, ["typedValue " ++ show sym ++ " viewAny " ++ parens (astSource (substAst subst expr))], Just viewAnyType)
|
||||
|
||||
lowerRuntimeApplication :: TricuAST -> TricuAST -> TricuAST -> RuntimeM (Integer, [String], Maybe ViewExpr)
|
||||
lowerRuntimeApplication f a expr = do
|
||||
(fSym, fNodes, fKnown) <- lowerRuntimeExpr f
|
||||
let expectedArg = case fKnown >>= viewExprFnParts of
|
||||
Just (argView : _, _) -> Just argView
|
||||
_ -> Nothing
|
||||
(aSym, aNodes, _) <- case expectedArg of
|
||||
Just view -> lowerRuntimeExprAgainst a view
|
||||
Nothing -> lowerRuntimeExpr a
|
||||
outSym <- freshRuntimeSym
|
||||
let outKnown = applicationResultView fKnown
|
||||
mapM_ (recordRuntimeKnown outSym) outKnown
|
||||
subst <- gets runtimeSubst
|
||||
let payload = astSource (substAst subst expr)
|
||||
applyNode = "typedApply " ++ show outSym ++ " " ++ show fSym ++ " " ++ show aSym ++ " " ++ parens payload
|
||||
pure (outSym, fNodes ++ aNodes ++ [applyNode], outKnown)
|
||||
|
||||
lowerRuntimeExprAgainst :: TricuAST -> ViewExpr -> RuntimeM (Integer, [String], Maybe ViewExpr)
|
||||
lowerRuntimeExprAgainst expr expected = do
|
||||
mBoundary <- dynamicBoundaryValue expr expected
|
||||
case mBoundary of
|
||||
Just resultValue -> pure resultValue
|
||||
Nothing -> do
|
||||
(sym, nodes, known) <- lowerRuntimeExpr expr
|
||||
subst <- gets runtimeSubst
|
||||
let requireNode = "typedRequire " ++ show sym ++ " " ++ parens (unsafeLowerViewExpr expected) ++ " " ++ parens (astSource (substAst subst expr))
|
||||
pure (sym, nodes ++ [requireNode], known)
|
||||
|
||||
-- IO continuations receive host-produced values whose structural View may not be
|
||||
-- statically known to the source lowerer. At an explicit annotated boundary we
|
||||
-- may introduce the requested base observation and let guarded Views perform the
|
||||
-- runtime assertion. This keeps guard failures in checked-exec instead of
|
||||
-- rejecting dynamic IO values as frontend-unknown Any.
|
||||
dynamicBoundaryValue :: TricuAST -> ViewExpr -> RuntimeM (Maybe (Integer, [String], Maybe ViewExpr))
|
||||
dynamicBoundaryValue expr expected = case expr of
|
||||
SVar name _ -> do
|
||||
symbols <- gets runtimeSymbols
|
||||
contracts <- gets runtimeContracts
|
||||
case (Map.lookup name symbols, Map.lookup name contracts) of
|
||||
(Nothing, Nothing) -> do
|
||||
subst <- gets runtimeSubst
|
||||
sym <- freshRuntimeSym
|
||||
let payload = astSource (substAst subst expr)
|
||||
knownView = dynamicBoundaryKnownView expected
|
||||
valueNode = "typedValue " ++ show sym ++ " " ++ parens (unsafeLowerViewExpr knownView) ++ " " ++ parens payload
|
||||
requireNode = "typedRequire " ++ show sym ++ " " ++ parens (unsafeLowerViewExpr expected) ++ " " ++ parens payload
|
||||
recordRuntimeKnown sym knownView
|
||||
pure (Just (sym, [valueNode, requireNode], Just knownView))
|
||||
_ -> pure Nothing
|
||||
_ -> pure Nothing
|
||||
|
||||
dynamicBoundaryKnownView :: ViewExpr -> ViewExpr
|
||||
dynamicBoundaryKnownView view = case viewExprAsType view of
|
||||
Just (VTGuarded base _) -> viewTypeToExpr base
|
||||
_ -> view
|
||||
|
||||
substAst :: Map.Map String TricuAST -> TricuAST -> TricuAST
|
||||
substAst subst expr = case expr of
|
||||
SVar name Nothing -> Map.findWithDefault expr name subst
|
||||
SApp f a -> SApp (substAst subst f) (substAst subst a)
|
||||
SLambda params body -> SLambda params (substAst (foldr Map.delete subst params) body)
|
||||
SList items -> SList (map (substAst subst) items)
|
||||
TStem x -> TStem (substAst subst x)
|
||||
TFork x y -> TFork (substAst subst x) (substAst subst y)
|
||||
_ -> expr
|
||||
|
||||
argRuntimeViewSource :: ViewExpr -> String
|
||||
argRuntimeViewSource view =
|
||||
"lazyBool (_ : guardedViewBase " ++ v ++ ") (_ : " ++ v ++ ") (guardedView? " ++ v ++ ")"
|
||||
where
|
||||
v = parens (unsafeLowerViewExpr view)
|
||||
|
||||
unsafeLowerViewExpr :: ViewExpr -> String
|
||||
unsafeLowerViewExpr view = case lowerViewExpr view of
|
||||
Right source -> source
|
||||
Left err -> errorWithoutStackTrace err
|
||||
|
||||
astSource :: TricuAST -> String
|
||||
astSource expr = case expr of
|
||||
SVar name Nothing -> name
|
||||
SVar name (Just hash) -> name ++ "#" ++ hash
|
||||
SInt n -> show n
|
||||
SStr s -> show s
|
||||
SList items -> "[" ++ unwords (map (parens . astSource) items) ++ "]"
|
||||
SApp f a -> parens (astSource f) ++ " " ++ parens (astSource a)
|
||||
SLambda params body -> parens (unwords params ++ " : " ++ astSource body)
|
||||
TLeaf -> "t"
|
||||
TStem x -> "(t " ++ astSource x ++ ")"
|
||||
TFork x y -> "(t " ++ astSource x ++ " " ++ astSource y ++ ")"
|
||||
SEmpty -> "[]"
|
||||
SDef name params body -> name ++ " " ++ unwords params ++ " = " ++ astSource body
|
||||
SDefAnn name args ret body -> name ++ " " ++ unwords (map defArgSource args) ++ maybe "" ((" =@" ++) . viewAnnSource) ret ++ " " ++ astSource body
|
||||
SImport path ns -> "!import " ++ show path ++ " " ++ ns
|
||||
|
||||
viewAnnSource :: ViewExpr -> String
|
||||
viewAnnSource = unsafeLowerViewExpr
|
||||
|
||||
defArgSource :: DefArg -> String
|
||||
defArgSource (DefBinder name Nothing) = name
|
||||
defArgSource (DefBinder name (Just view)) = name ++ "@" ++ viewAnnSource view
|
||||
defArgSource (DefPhantom view) = "@" ++ viewAnnSource view
|
||||
|
||||
parens :: String -> String
|
||||
parens s = "(" ++ s ++ ")"
|
||||
@@ -1,319 +1,17 @@
|
||||
module ContentStore where
|
||||
module ContentStore
|
||||
( module ContentStore.Object
|
||||
, module ContentStore.Filesystem
|
||||
, module ContentStore.Arboricx
|
||||
, module ContentStore.Alias
|
||||
, module ContentStore.Resolver
|
||||
, module ContentStore.ViewTree
|
||||
, module ContentStore.ViewContract
|
||||
) where
|
||||
|
||||
import Research
|
||||
|
||||
import Control.Monad (foldM, forM_, void)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Char (isHexDigit)
|
||||
import Data.List (nub, sort)
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Database.SQLite.Simple
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
import System.Directory (createDirectoryIfMissing, getXdgDirectory, XdgDirectory(..))
|
||||
import System.Environment (lookupEnv)
|
||||
import System.Exit (die)
|
||||
import System.FilePath ((</>), takeDirectory)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
|
||||
data StoredNode = StoredNode ByteString deriving (Show)
|
||||
|
||||
instance FromRow StoredNode where
|
||||
fromRow = StoredNode <$> field
|
||||
|
||||
data StoredTerm = StoredTerm
|
||||
{ termHash :: Text
|
||||
, termNames :: Text
|
||||
, termMetadata :: Text
|
||||
, termCreatedAt :: Integer
|
||||
, termTags :: Text
|
||||
} deriving (Show)
|
||||
|
||||
instance FromRow StoredTerm where
|
||||
fromRow = StoredTerm <$> field <*> field <*> field <*> field <*> field
|
||||
|
||||
parseNameList :: Text -> [Text]
|
||||
parseNameList = filter (not . T.null) . T.splitOn ","
|
||||
|
||||
serializeNameList :: [Text] -> Text
|
||||
serializeNameList = T.intercalate "," . nub . sort
|
||||
|
||||
initContentStore :: IO Connection
|
||||
initContentStore = initContentStoreWithPath Nothing
|
||||
|
||||
-- | Initialise a content store with an explicit path, or fall back
|
||||
-- to the environment variable / default location.
|
||||
initContentStoreWithPath :: Maybe FilePath -> IO Connection
|
||||
initContentStoreWithPath mPath = do
|
||||
dbPath <- case mPath of
|
||||
Just p -> return p
|
||||
Nothing -> getContentStorePath
|
||||
createDirectoryIfMissing True (takeDirectory dbPath)
|
||||
conn <- open dbPath
|
||||
setupDatabase conn
|
||||
return conn
|
||||
|
||||
-- | Initialise a database connection (file-backed or in-memory).
|
||||
-- This is factored out so tests can reuse it with ":memory:".
|
||||
setupDatabase :: Connection -> IO ()
|
||||
setupDatabase conn = do
|
||||
execute_ conn "CREATE TABLE IF NOT EXISTS terms (\
|
||||
\hash TEXT PRIMARY KEY, \
|
||||
\names TEXT, \
|
||||
\metadata TEXT, \
|
||||
\created_at INTEGER DEFAULT (strftime('%s','now')), \
|
||||
\tags TEXT DEFAULT '')"
|
||||
execute_ conn "CREATE INDEX IF NOT EXISTS terms_names_idx ON terms(names)"
|
||||
execute_ conn "CREATE INDEX IF NOT EXISTS terms_tags_idx ON terms(tags)"
|
||||
execute_ conn "CREATE TABLE IF NOT EXISTS merkle_nodes (\
|
||||
\hash TEXT PRIMARY KEY, \
|
||||
\node_data BLOB NOT NULL)"
|
||||
-- Seed canonical Leaf node payload (0x00)
|
||||
putMerkleNode conn NLeaf
|
||||
|
||||
-- | Create an in-memory ContentStore connection (for tests).
|
||||
newContentStore :: IO Connection
|
||||
newContentStore = do
|
||||
conn <- open ":memory:"
|
||||
setupDatabase conn
|
||||
return conn
|
||||
|
||||
getContentStorePath :: IO FilePath
|
||||
getContentStorePath = do
|
||||
maybeLocalPath <- lookupEnv "TRICU_DB_PATH"
|
||||
case maybeLocalPath of
|
||||
Just p -> return p
|
||||
Nothing -> do
|
||||
dataDir <- getXdgDirectory XdgData "tricu"
|
||||
return $ dataDir </> "content-store.db"
|
||||
|
||||
|
||||
|
||||
hashTerm :: T -> Text
|
||||
hashTerm = nodeHash . buildMerkle
|
||||
|
||||
storeTerm :: Connection -> [String] -> T -> IO Text
|
||||
storeTerm conn newNamesStrList term = do
|
||||
let termHashText = hashTerm term
|
||||
newNamesTextList = map T.pack newNamesStrList
|
||||
metadataText = T.pack "{}"
|
||||
-- Store all Merkle nodes for this term. This traversal is where lazy T
|
||||
-- values are forced into normalized Merkle nodes for persistence.
|
||||
hPutStrLn stderr $ "[tricu] storing " ++ show newNamesStrList
|
||||
_ <- storeMerkleNodes conn term
|
||||
existingNamesQuery <- query conn
|
||||
"SELECT names FROM terms WHERE hash = ?"
|
||||
(Only termHashText) :: IO [Only Text]
|
||||
|
||||
case existingNamesQuery of
|
||||
[] -> do
|
||||
let allNamesToStore = serializeNameList newNamesTextList
|
||||
execute conn
|
||||
"INSERT INTO terms (hash, names, metadata, tags) VALUES (?, ?, ?, ?)"
|
||||
(termHashText, allNamesToStore, metadataText, T.pack "")
|
||||
[(Only currentNamesText)] -> do
|
||||
let currentNamesList = parseNameList currentNamesText
|
||||
let combinedNamesList = currentNamesList ++ newNamesTextList
|
||||
let allNamesToStore = serializeNameList combinedNamesList
|
||||
execute conn
|
||||
"UPDATE terms SET names = ?, metadata = ? WHERE hash = ?"
|
||||
(allNamesToStore, metadataText, termHashText)
|
||||
_ -> errorWithoutStackTrace $ "Multiple terms with same hash? " ++ show (length existingNamesQuery)
|
||||
|
||||
return termHashText
|
||||
|
||||
-- | Reconstruct a Tree Calculus term from its Merkle root hash.
|
||||
-- Recursively loads nodes and rebuilds the T structure.
|
||||
loadTree :: Connection -> MerkleHash -> IO (Maybe T)
|
||||
loadTree conn h = do
|
||||
maybeNode <- getNodeMerkle conn h
|
||||
case maybeNode of
|
||||
Nothing -> return Nothing
|
||||
Just node -> Just <$> buildTree node
|
||||
where
|
||||
buildTree :: Node -> IO T
|
||||
buildTree NLeaf = return Leaf
|
||||
buildTree (NStem childHash) = do
|
||||
child <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn childHash
|
||||
return (Stem child)
|
||||
buildTree (NFork lHash rHash) = do
|
||||
left <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn lHash
|
||||
right <- fromMaybe (errorWithoutStackTrace "BUG: stored hash not found") <$> loadTree conn rHash
|
||||
return (Fork left right)
|
||||
|
||||
-- | Store all nodes of a Merkle DAG by traversing the Term and building/storing nodes.
|
||||
-- Returns the hash of the root node.
|
||||
storeMerkleNodes :: Connection -> T -> IO MerkleHash
|
||||
storeMerkleNodes conn Leaf = do
|
||||
putMerkleNode conn NLeaf
|
||||
return $ nodeHash NLeaf
|
||||
storeMerkleNodes conn (Stem t) = do
|
||||
childHash <- storeMerkleNodes conn t
|
||||
let thisNode = NStem childHash
|
||||
putMerkleNode conn thisNode
|
||||
return $ nodeHash thisNode
|
||||
storeMerkleNodes conn (Fork l r) = do
|
||||
leftHash <- storeMerkleNodes conn l
|
||||
rightHash <- storeMerkleNodes conn r
|
||||
let thisNode = NFork leftHash rightHash
|
||||
putMerkleNode conn thisNode
|
||||
return $ nodeHash thisNode
|
||||
|
||||
|
||||
-- | Insert a Merkle node into the store (idempotent).
|
||||
putMerkleNode :: Connection -> Node -> IO ()
|
||||
putMerkleNode conn node =
|
||||
execute conn "INSERT OR IGNORE INTO merkle_nodes (hash, node_data) VALUES (?, ?)"
|
||||
(nodeHash node, serializeNode node)
|
||||
|
||||
-- | Retrieve a Merkle node by its hash.
|
||||
getNodeMerkle :: Connection -> MerkleHash -> IO (Maybe Node)
|
||||
getNodeMerkle conn h =
|
||||
queryMaybeOne conn "SELECT node_data FROM merkle_nodes WHERE hash = ?" (Only h) >>= \case
|
||||
Just (StoredNode bs) -> return $ Just (deserializeNode bs)
|
||||
Nothing -> return Nothing
|
||||
|
||||
|
||||
|
||||
hashToTerm :: Connection -> Text -> IO (Maybe StoredTerm)
|
||||
hashToTerm conn hashText =
|
||||
queryMaybeOne conn (selectStoredTermFields <> " WHERE hash = ?") (Only hashText)
|
||||
|
||||
nameToTerm :: Connection -> Text -> IO (Maybe StoredTerm)
|
||||
nameToTerm conn nameText =
|
||||
queryMaybeOne conn
|
||||
(selectStoredTermFields <> " WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC LIMIT 1")
|
||||
(nameText, nameText <> T.pack ",%", T.pack "%," <> nameText <> T.pack ",%", T.pack "%," <> nameText)
|
||||
|
||||
listStoredTerms :: Connection -> IO [StoredTerm]
|
||||
listStoredTerms conn =
|
||||
query_ conn (selectStoredTermFields <> " ORDER BY created_at DESC")
|
||||
|
||||
storeEnvironment :: Connection -> Env -> IO ()
|
||||
storeEnvironment conn env = do
|
||||
let defs = Map.toList $ Map.delete "!result" env
|
||||
let groupedDefs = Map.toList $ Map.fromListWith (++) [(term, [name]) | (name, term) <- defs]
|
||||
|
||||
forM_ groupedDefs $ \(term, namesList) -> case namesList of
|
||||
_:_ -> void $ storeTerm conn namesList term
|
||||
_ -> errorWithoutStackTrace "storeEnvironment: empty names list"
|
||||
|
||||
loadTerm :: Connection -> String -> IO (Maybe T)
|
||||
loadTerm conn identifier = do
|
||||
result <- getTerm conn (T.pack identifier)
|
||||
case result of
|
||||
Just storedTerm -> loadTree conn (termHash storedTerm)
|
||||
Nothing -> return Nothing
|
||||
|
||||
getTerm :: Connection -> Text -> IO (Maybe StoredTerm)
|
||||
getTerm conn identifier = do
|
||||
if '#' `elem` (T.unpack identifier)
|
||||
then hashToTerm conn (T.pack $ drop 1 (T.unpack identifier))
|
||||
else nameToTerm conn identifier
|
||||
|
||||
loadEnvironment :: Connection -> IO Env
|
||||
loadEnvironment conn = do
|
||||
terms <- listStoredTerms conn
|
||||
foldM addTermToEnv Map.empty terms
|
||||
where
|
||||
addTermToEnv env storedTerm = do
|
||||
maybeT <- loadTree conn (termHash storedTerm)
|
||||
case maybeT of
|
||||
Just t -> do
|
||||
let namesList = parseNameList (termNames storedTerm)
|
||||
return $ foldl (\e name -> Map.insert (T.unpack name) t e) env namesList
|
||||
Nothing -> return env
|
||||
|
||||
termVersions :: Connection -> String -> IO [(Text, T, Integer)]
|
||||
termVersions conn name = do
|
||||
let nameText = T.pack name
|
||||
results <- query conn
|
||||
("SELECT hash, created_at FROM terms WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC")
|
||||
(nameText, nameText <> T.pack ",%", T.pack "%," <> nameText <> T.pack ",%", T.pack "%," <> nameText)
|
||||
|
||||
catMaybes <$> mapM (\(hashVal, timestamp) -> do
|
||||
maybeT <- loadTree conn hashVal
|
||||
return $ fmap (\t -> (hashVal, t, timestamp)) maybeT
|
||||
) results
|
||||
|
||||
setTag :: Connection -> Text -> Text -> IO ()
|
||||
setTag conn hash tagValue = do
|
||||
exists <- termExists conn hash
|
||||
if exists
|
||||
then do
|
||||
currentTagsQuery <- query conn "SELECT tags FROM terms WHERE hash = ?" (Only hash) :: IO [Only Text]
|
||||
case currentTagsQuery of
|
||||
[Only tagsText] -> do
|
||||
let tagsList = parseNameList tagsText
|
||||
newTagsList = tagValue : tagsList
|
||||
newTags = serializeNameList newTagsList
|
||||
execute conn "UPDATE terms SET tags = ? WHERE hash = ?" (newTags, hash)
|
||||
_ -> putStrLn $ "Term with hash " ++ T.unpack hash ++ " not found (should not happen if exists is true)"
|
||||
else
|
||||
putStrLn $ "Term with hash " ++ T.unpack hash ++ " does not exist"
|
||||
|
||||
termExists :: Connection -> Text -> IO Bool
|
||||
termExists conn hash = do
|
||||
results <- query conn "SELECT 1 FROM terms WHERE hash = ? LIMIT 1" (Only hash) :: IO [[Int]]
|
||||
return $ not (null results)
|
||||
|
||||
termToTags :: Connection -> Text -> IO [Text]
|
||||
termToTags conn hash = do
|
||||
tagsQuery <- query conn "SELECT tags FROM terms WHERE hash = ?" (Only hash) :: IO [Only Text]
|
||||
case tagsQuery of
|
||||
[Only tagsText] -> return $ parseNameList tagsText
|
||||
_ -> return []
|
||||
|
||||
tagToTerm :: Connection -> Text -> IO [StoredTerm]
|
||||
tagToTerm conn tagValue = do
|
||||
let pattern = "%" <> tagValue <> "%"
|
||||
query conn (selectStoredTermFields <> " WHERE tags LIKE ? ORDER BY created_at DESC") (Only pattern)
|
||||
|
||||
allTermTags :: Connection -> IO [StoredTerm]
|
||||
allTermTags conn = do
|
||||
query_ conn (selectStoredTermFields <> " WHERE tags IS NOT NULL AND tags != '' ORDER BY created_at DESC")
|
||||
|
||||
selectStoredTermFields :: Query
|
||||
selectStoredTermFields = "SELECT hash, names, metadata, created_at, tags FROM terms"
|
||||
|
||||
queryMaybeOne :: (FromRow r, ToRow q) => Connection -> Query -> q -> IO (Maybe r)
|
||||
queryMaybeOne conn qry params = do
|
||||
results <- query conn qry params
|
||||
case results of
|
||||
[row] -> return $ Just row
|
||||
_ -> return Nothing
|
||||
|
||||
-- | Resolve a user-supplied identifier (full/prefix hash, term name) to
|
||||
-- a single term hash and the list of names bound to it. Dies on
|
||||
-- ambiguity or missing term (matching the CLI @export@ semantics).
|
||||
resolveExportTarget :: Connection -> String -> IO (Text, [Text])
|
||||
resolveExportTarget conn input = do
|
||||
let raw = T.pack $ dropWhile (== '#') input
|
||||
byName <- query conn
|
||||
"SELECT hash FROM terms WHERE (names = ? OR names LIKE ? OR names LIKE ? OR names LIKE ?) ORDER BY created_at DESC"
|
||||
(raw, raw <> T.pack ",%", T.pack "," <> raw <> T.pack ",%", T.pack "%," <> raw) :: IO [Only T.Text]
|
||||
case byName of
|
||||
[Only fullHash] -> namesForHash conn fullHash >>= \names -> return (fullHash, names)
|
||||
(_:_) -> die $ "Ambiguous term name: " ++ input
|
||||
[] -> do
|
||||
byHash <- query conn "SELECT hash FROM terms WHERE hash LIKE ? ORDER BY created_at DESC"
|
||||
(Only (raw <> T.pack "%")) :: IO [Only T.Text]
|
||||
case byHash of
|
||||
[Only fullHash] -> namesForHash conn fullHash >>= \names -> return (fullHash, names)
|
||||
[] -> if looksLikeHash raw
|
||||
then return (raw, [])
|
||||
else die $ "No term found matching: " ++ input
|
||||
_ -> die $ "Ambiguous hash prefix: " ++ input
|
||||
|
||||
namesForHash :: Connection -> Text -> IO [Text]
|
||||
namesForHash conn h = do
|
||||
stored <- hashToTerm conn h
|
||||
return $ maybe [] (parseNameList . termNames) stored
|
||||
|
||||
-- | Return 'True' when @t@ looks like a full or partial SHA-256 hex hash.
|
||||
looksLikeHash :: Text -> Bool
|
||||
looksLikeHash t =
|
||||
let len = T.length t
|
||||
in len >= 16 && len <= 64 && T.all isHexDigit t
|
||||
import ContentStore.Arboricx
|
||||
import ContentStore.Alias
|
||||
import ContentStore.Filesystem
|
||||
import ContentStore.Object
|
||||
import ContentStore.Resolver
|
||||
import ContentStore.ViewTree
|
||||
import ContentStore.ViewContract
|
||||
|
||||
81
src/ContentStore/Alias.hs
Normal file
81
src/ContentStore/Alias.hs
Normal file
@@ -0,0 +1,81 @@
|
||||
module ContentStore.Alias
|
||||
( AliasKind(..)
|
||||
, ObjectRef(..)
|
||||
, aliasKindDirectory
|
||||
, writeAlias
|
||||
, readAlias
|
||||
, listAliases
|
||||
) where
|
||||
|
||||
import ContentStore.Filesystem (ensureStore)
|
||||
import ContentStore.Object
|
||||
|
||||
import Data.Text (Text)
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist, listDirectory)
|
||||
import System.FilePath ((</>))
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.IO as TextIO
|
||||
|
||||
-- | Mutable workspace alias categories. Aliases are human-facing pointers to
|
||||
-- immutable content objects; they are not content identity.
|
||||
data AliasKind
|
||||
= NameAlias
|
||||
| ModuleAlias
|
||||
| PackageAlias
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data ObjectRef = ObjectRef
|
||||
{ objectRefKind :: Text
|
||||
, objectRefHash :: ObjectHash
|
||||
} deriving (Eq, Ord, Show)
|
||||
|
||||
aliasKindDirectory :: AliasKind -> FilePath
|
||||
aliasKindDirectory NameAlias = "names"
|
||||
aliasKindDirectory ModuleAlias = "modules"
|
||||
aliasKindDirectory PackageAlias = "packages"
|
||||
|
||||
writeAlias :: StorePath -> AliasKind -> Text -> ObjectRef -> IO ()
|
||||
writeAlias store@(StorePath root) kind name ref = do
|
||||
ensureStore store
|
||||
let dir = root </> "aliases" </> aliasKindDirectory kind
|
||||
createDirectoryIfMissing True dir
|
||||
TextIO.writeFile (dir </> Text.unpack name) (encodeObjectRef ref)
|
||||
|
||||
readAlias :: StorePath -> AliasKind -> Text -> IO (Maybe ObjectRef)
|
||||
readAlias store@(StorePath root) kind name = do
|
||||
ensureStore store
|
||||
let path = root </> "aliases" </> aliasKindDirectory kind </> Text.unpack name
|
||||
exists <- doesFileExist path
|
||||
if not exists
|
||||
then return Nothing
|
||||
else decodeObjectRef <$> TextIO.readFile path
|
||||
|
||||
listAliases :: StorePath -> AliasKind -> IO [(Text, ObjectRef)]
|
||||
listAliases store@(StorePath root) kind = do
|
||||
ensureStore store
|
||||
let dir = root </> "aliases" </> aliasKindDirectory kind
|
||||
names <- listDirectory dir
|
||||
fmap concat $ mapM load names
|
||||
where
|
||||
load name = do
|
||||
mRef <- readAlias store kind (Text.pack name)
|
||||
return $ maybe [] (\ref -> [(Text.pack name, ref)]) mRef
|
||||
|
||||
encodeObjectRef :: ObjectRef -> Text
|
||||
encodeObjectRef ref = Text.unlines
|
||||
[ "kind: " <> objectRefKind ref
|
||||
, "hash: " <> objectRefHash ref
|
||||
]
|
||||
|
||||
decodeObjectRef :: Text -> Maybe ObjectRef
|
||||
decodeObjectRef txt = do
|
||||
kind <- lookupField "kind" fields
|
||||
hash <- lookupField "hash" fields
|
||||
return ObjectRef { objectRefKind = kind, objectRefHash = hash }
|
||||
where
|
||||
fields = map parseLine (Text.lines txt)
|
||||
parseLine line =
|
||||
let (k, rest) = Text.breakOn ":" line
|
||||
in (Text.strip k, Text.strip (Text.drop 1 rest))
|
||||
lookupField key = lookup key
|
||||
94
src/ContentStore/Arboricx.hs
Normal file
94
src/ContentStore/Arboricx.hs
Normal file
@@ -0,0 +1,94 @@
|
||||
module ContentStore.Arboricx
|
||||
( merkleNodeDomain
|
||||
, putNode
|
||||
, getNode
|
||||
, treeTermDomain
|
||||
, encodeTreeTerm
|
||||
, decodeTreeTerm
|
||||
, putTreeTerm
|
||||
, getTreeTerm
|
||||
, putTree
|
||||
, getTree
|
||||
) where
|
||||
|
||||
import ContentStore.Filesystem
|
||||
import ContentStore.Object
|
||||
import Research
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
|
||||
merkleNodeDomain :: Domain
|
||||
merkleNodeDomain = Domain "arboricx.merkle.node.v1"
|
||||
|
||||
treeTermDomain :: Domain
|
||||
treeTermDomain = Domain "arboricx.tree-term.v1"
|
||||
|
||||
putNode :: StorePath -> Node -> IO ObjectHash
|
||||
putNode store node = putObject store merkleNodeDomain (serializeNode node)
|
||||
|
||||
getNode :: StorePath -> ObjectHash -> IO (Maybe Node)
|
||||
getNode store h = fmap deserializeNode <$> getObject store h
|
||||
|
||||
-- | Store a complete normal tree as one content object. Merkle nodes remain
|
||||
-- available for DAG use cases, but module executable exports use this object
|
||||
-- kind to avoid filesystem writes for every subtree of large normal forms.
|
||||
encodeTreeTerm :: T -> BS.ByteString
|
||||
encodeTreeTerm Leaf = BS.pack [0x00]
|
||||
encodeTreeTerm (Stem t) = BS.cons 0x01 (encodeTreeTerm t)
|
||||
encodeTreeTerm (Fork l r) = BS.cons 0x02 (encodeTreeTerm l <> encodeTreeTerm r)
|
||||
|
||||
decodeTreeTerm :: BS.ByteString -> Either String T
|
||||
decodeTreeTerm payload = do
|
||||
(term, rest) <- getTerm payload
|
||||
if BS.null rest
|
||||
then Right term
|
||||
else Left "trailing bytes after tree term"
|
||||
where
|
||||
getTerm bs = case BS.uncons bs of
|
||||
Nothing -> Left "unexpected end of tree term"
|
||||
Just (0x00, rest) -> Right (Leaf, rest)
|
||||
Just (0x01, rest) -> do
|
||||
(child, afterChild) <- getTerm rest
|
||||
Right (Stem child, afterChild)
|
||||
Just (0x02, rest) -> do
|
||||
(left, afterLeft) <- getTerm rest
|
||||
(right, afterRight) <- getTerm afterLeft
|
||||
Right (Fork left right, afterRight)
|
||||
Just (tag, _) -> Left $ "unknown tree term tag: " ++ show tag
|
||||
|
||||
putTreeTerm :: StorePath -> T -> IO ObjectHash
|
||||
putTreeTerm store = putObject store treeTermDomain . encodeTreeTerm
|
||||
|
||||
getTreeTerm :: StorePath -> ObjectHash -> IO (Maybe T)
|
||||
getTreeTerm store h = do
|
||||
mPayload <- getObject store h
|
||||
case mPayload of
|
||||
Nothing -> pure Nothing
|
||||
Just payload -> case decodeTreeTerm payload of
|
||||
Left err -> fail $ "invalid tree term " ++ show h ++ ": " ++ err
|
||||
Right term -> pure (Just term)
|
||||
|
||||
putTree :: StorePath -> T -> IO ObjectHash
|
||||
putTree store = go
|
||||
where
|
||||
go Leaf = putNode store NLeaf
|
||||
go (Stem t) = do
|
||||
child <- go t
|
||||
putNode store (NStem child)
|
||||
go (Fork l r) = do
|
||||
left <- go l
|
||||
right <- go r
|
||||
putNode store (NFork left right)
|
||||
|
||||
getTree :: StorePath -> ObjectHash -> IO (Maybe T)
|
||||
getTree store root = do
|
||||
mNode <- getNode store root
|
||||
case mNode of
|
||||
Nothing -> return Nothing
|
||||
Just node -> case node of
|
||||
NLeaf -> return (Just Leaf)
|
||||
NStem child -> fmap Stem <$> getTree store child
|
||||
NFork left right -> do
|
||||
ml <- getTree store left
|
||||
mr <- getTree store right
|
||||
return $ Fork <$> ml <*> mr
|
||||
37
src/ContentStore/Bundle.hs
Normal file
37
src/ContentStore/Bundle.hs
Normal file
@@ -0,0 +1,37 @@
|
||||
module ContentStore.Bundle
|
||||
( packBundleFromStore
|
||||
, unpackBundleToStore
|
||||
) where
|
||||
|
||||
import ContentStore.Arboricx
|
||||
import ContentStore.Object
|
||||
import Wire
|
||||
|
||||
import Control.Monad (forM)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Vector as V
|
||||
|
||||
-- | Pack named CAS tree terms into an indexed Arboricx transport bundle.
|
||||
packBundleFromStore :: StorePath -> [(Text, ObjectHash)] -> IO Bundle
|
||||
packBundleFromStore store exports = do
|
||||
terms <- forM exports $ \(name, root) -> do
|
||||
mt <- getTreeTerm store root
|
||||
case mt of
|
||||
Nothing -> fail $ "CAS tree term not found: " ++ show root
|
||||
Just term -> return (name, term)
|
||||
return (buildBundle terms)
|
||||
|
||||
-- | Unpack an indexed Arboricx transport bundle into CAS tree terms.
|
||||
-- Returns each manifest export name paired with its stored CAS tree-term hash.
|
||||
unpackBundleToStore :: StorePath -> ByteString -> IO [(Text, ObjectHash)]
|
||||
unpackBundleToStore store bs = case decodeBundle bs of
|
||||
Left err -> fail $ "ContentStore.Bundle.unpackBundleToStore decode: " ++ err
|
||||
Right bundle -> case verifyBundle bundle of
|
||||
Left err -> fail $ "ContentStore.Bundle.unpackBundleToStore verify: " ++ err
|
||||
Right () -> do
|
||||
let terms = reconstructBundleTerms (bundleNodes bundle)
|
||||
forM (manifestExports $ bundleManifest bundle) $ \exported -> do
|
||||
let term = terms V.! fromIntegral (exportRoot exported)
|
||||
root <- putTreeTerm store term
|
||||
return (exportName exported, root)
|
||||
60
src/ContentStore/Filesystem.hs
Normal file
60
src/ContentStore/Filesystem.hs
Normal file
@@ -0,0 +1,60 @@
|
||||
module ContentStore.Filesystem
|
||||
( putObject
|
||||
, getObject
|
||||
, objectPath
|
||||
, ensureStore
|
||||
) where
|
||||
|
||||
import ContentStore.Object
|
||||
|
||||
import Control.Monad (unless, when)
|
||||
import Data.Text (unpack)
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile, renameFile)
|
||||
import System.FilePath ((</>))
|
||||
import System.IO (hClose, openBinaryTempFile)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
|
||||
ensureStore :: StorePath -> IO ()
|
||||
ensureStore (StorePath root) = do
|
||||
createDirectoryIfMissing True (root </> "objects")
|
||||
createDirectoryIfMissing True (root </> "aliases" </> "names")
|
||||
createDirectoryIfMissing True (root </> "aliases" </> "modules")
|
||||
createDirectoryIfMissing True (root </> "aliases" </> "packages")
|
||||
createDirectoryIfMissing True (root </> "manifests")
|
||||
createDirectoryIfMissing True (root </> "tmp")
|
||||
|
||||
objectPath :: StorePath -> ObjectHash -> FilePath
|
||||
objectPath (StorePath root) h = root </> "objects" </> shardForHash h </> unpack h
|
||||
|
||||
putObject :: StorePath -> Domain -> BS.ByteString -> IO ObjectHash
|
||||
putObject store@(StorePath root) domain payload = do
|
||||
ensureStore store
|
||||
let h = hashObject domain payload
|
||||
shardDir = root </> "objects" </> shardForHash h
|
||||
finalPath = objectPath store h
|
||||
createDirectoryIfMissing True shardDir
|
||||
exists <- doesFileExist finalPath
|
||||
if exists
|
||||
then verifyExisting finalPath
|
||||
else do
|
||||
let tmpDir = root </> "tmp"
|
||||
(tmpPath, handle) <- openBinaryTempFile tmpDir (unpack h ++ ".tmp")
|
||||
BS.hPut handle payload
|
||||
hClose handle
|
||||
raced <- doesFileExist finalPath
|
||||
if raced
|
||||
then removeFile tmpPath >> verifyExisting finalPath
|
||||
else renameFile tmpPath finalPath
|
||||
return h
|
||||
where
|
||||
verifyExisting path = do
|
||||
existing <- BS.readFile path
|
||||
when (existing /= payload) $
|
||||
fail $ "content-addressed object exists with mismatched bytes: " ++ path
|
||||
|
||||
getObject :: StorePath -> ObjectHash -> IO (Maybe BS.ByteString)
|
||||
getObject store h = do
|
||||
let path = objectPath store h
|
||||
exists <- doesFileExist path
|
||||
if exists then Just <$> BS.readFile path else return Nothing
|
||||
45
src/ContentStore/Object.hs
Normal file
45
src/ContentStore/Object.hs
Normal file
@@ -0,0 +1,45 @@
|
||||
module ContentStore.Object
|
||||
( Domain(..)
|
||||
, ObjectHash
|
||||
, StorePath(..)
|
||||
, hashObject
|
||||
, hashToText
|
||||
, textToHashBytes
|
||||
, shardForHash
|
||||
) where
|
||||
|
||||
import Crypto.Hash (Digest, SHA256, hash)
|
||||
import Data.ByteArray (convert)
|
||||
import Data.ByteString.Base16 (decode, encode)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Text as T
|
||||
|
||||
newtype Domain = Domain { unDomain :: Text }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
type ObjectHash = Text
|
||||
|
||||
newtype StorePath = StorePath { unStorePath :: FilePath }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
hashObject :: Domain -> BS.ByteString -> ObjectHash
|
||||
hashObject (Domain domain) payload = hashToText digest
|
||||
where
|
||||
digest :: Digest SHA256
|
||||
digest = hash (encodeUtf8 domain <> BS.pack [0x00] <> payload)
|
||||
|
||||
hashToText :: Digest SHA256 -> Text
|
||||
hashToText = decodeUtf8 . encode . (convert :: Digest SHA256 -> BS.ByteString)
|
||||
|
||||
textToHashBytes :: Text -> Either String BS.ByteString
|
||||
textToHashBytes h = case decode (encodeUtf8 h) of
|
||||
Left _ -> Left "invalid hexadecimal hash"
|
||||
Right raw
|
||||
| BS.length raw == 32 -> Right raw
|
||||
| otherwise -> Left "hash must decode to 32 bytes"
|
||||
|
||||
shardForHash :: ObjectHash -> FilePath
|
||||
shardForHash = T.unpack . T.take 3
|
||||
110
src/ContentStore/Resolver.hs
Normal file
110
src/ContentStore/Resolver.hs
Normal file
@@ -0,0 +1,110 @@
|
||||
module ContentStore.Resolver
|
||||
( ObjectResolver(..)
|
||||
, filesystemResolver
|
||||
, cachedFilesystemResolver
|
||||
, resolveObjectByHash
|
||||
, resolveManifest
|
||||
, resolveTree
|
||||
) where
|
||||
|
||||
import ContentStore.Alias
|
||||
import ContentStore.Arboricx
|
||||
import ContentStore.Filesystem
|
||||
import ContentStore.Object
|
||||
import Module.Manifest
|
||||
import Research (Node(..), T, deserializeNode)
|
||||
import qualified Research
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef')
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- | Object and alias resolution capability. Module/import code should depend on
|
||||
-- this boundary rather than on a concrete filesystem store. Future resolvers can
|
||||
-- add trusted remotes, registries, or caches while preserving the same verified
|
||||
-- content-addressed interface.
|
||||
data ObjectResolver = ObjectResolver
|
||||
{ resolverAlias :: AliasKind -> T.Text -> IO (Maybe ObjectRef)
|
||||
, resolverObject :: ObjectRef -> IO (Maybe ByteString)
|
||||
, resolverManifest :: ObjectHash -> IO (Maybe ModuleManifest)
|
||||
, resolverTree :: ObjectHash -> IO (Maybe T)
|
||||
}
|
||||
|
||||
filesystemResolver :: StorePath -> ObjectResolver
|
||||
filesystemResolver store = resolver
|
||||
where
|
||||
resolver = ObjectResolver
|
||||
{ resolverAlias = readAlias store
|
||||
, resolverObject = \ref -> getObject store (objectRefHash ref)
|
||||
, resolverManifest = resolveManifestFromObjects resolver
|
||||
, resolverTree = resolveTreeFromObjects resolver
|
||||
}
|
||||
|
||||
cachedFilesystemResolver :: StorePath -> IO ObjectResolver
|
||||
cachedFilesystemResolver store = do
|
||||
objectCache <- newIORef Map.empty
|
||||
manifestCache <- newIORef Map.empty
|
||||
treeCache <- newIORef Map.empty
|
||||
let resolver = ObjectResolver
|
||||
{ resolverAlias = readAlias store
|
||||
, resolverObject = cachedLookup objectCache (\ref -> getObject store (objectRefHash ref))
|
||||
, resolverManifest = cachedLookup manifestCache (resolveManifestFromObjects resolver)
|
||||
, resolverTree = cachedLookup treeCache (resolveTreeFromObjects resolver)
|
||||
}
|
||||
return resolver
|
||||
where
|
||||
cachedLookup :: Ord k => IORef (Map.Map k v) -> (k -> IO v) -> k -> IO v
|
||||
cachedLookup ref load key = do
|
||||
cache <- readIORef ref
|
||||
case Map.lookup key cache of
|
||||
Just value -> return value
|
||||
Nothing -> do
|
||||
value <- load key
|
||||
atomicModifyIORef' ref (\m -> (Map.insert key value m, ()))
|
||||
return value
|
||||
|
||||
resolveObjectByHash :: ObjectResolver -> T.Text -> ObjectHash -> IO (Maybe ByteString)
|
||||
resolveObjectByHash resolver kind h =
|
||||
resolverObject resolver (ObjectRef kind h)
|
||||
|
||||
resolveManifest :: ObjectResolver -> ObjectHash -> IO (Maybe ModuleManifest)
|
||||
resolveManifest = resolverManifest
|
||||
|
||||
resolveManifestFromObjects :: ObjectResolver -> ObjectHash -> IO (Maybe ModuleManifest)
|
||||
resolveManifestFromObjects resolver h = do
|
||||
mBytes <- resolveObjectByHash resolver (unDomain manifestDomain) h
|
||||
case mBytes of
|
||||
Nothing -> return Nothing
|
||||
Just bytes -> case decodeManifest bytes of
|
||||
Left err -> fail $ "invalid module manifest " ++ T.unpack h ++ ": " ++ err
|
||||
Right manifest -> return (Just manifest)
|
||||
|
||||
resolveTree :: ObjectResolver -> ObjectHash -> IO (Maybe T)
|
||||
resolveTree = resolverTree
|
||||
|
||||
resolveTreeFromObjects :: ObjectResolver -> ObjectHash -> IO (Maybe T)
|
||||
resolveTreeFromObjects resolver h = do
|
||||
mNode <- resolveNode resolver h
|
||||
case mNode of
|
||||
Nothing -> return Nothing
|
||||
Just node -> hydrate node
|
||||
where
|
||||
resolveNode r nodeHash = do
|
||||
mBytes <- resolveObjectByHash r (unDomain merkleNodeDomain) nodeHash
|
||||
case mBytes of
|
||||
Nothing -> return Nothing
|
||||
Just bytes -> return (Just (deserializeNode bytes))
|
||||
|
||||
hydrate NLeaf = return (Just Research.Leaf)
|
||||
hydrate (NStem child) = fmap Research.Stem <$> hydrateHash child
|
||||
hydrate (NFork left right) = do
|
||||
l <- hydrateHash left
|
||||
r <- hydrateHash right
|
||||
return $ Research.Fork <$> l <*> r
|
||||
|
||||
hydrateHash nodeHash = do
|
||||
mChild <- resolveNode resolver nodeHash
|
||||
case mChild of
|
||||
Nothing -> return Nothing
|
||||
Just child -> hydrate child
|
||||
230
src/ContentStore/ViewContract.hs
Normal file
230
src/ContentStore/ViewContract.hs
Normal file
@@ -0,0 +1,230 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module ContentStore.ViewContract
|
||||
( viewContractTypeKind
|
||||
, viewContractTypeDomain
|
||||
, encodeViewType
|
||||
, decodeViewType
|
||||
, treeToViewType
|
||||
, viewTypeToTree
|
||||
, putViewType
|
||||
, getViewType
|
||||
) where
|
||||
|
||||
import ContentStore.Alias (ObjectRef(..))
|
||||
import ContentStore.Arboricx (decodeTreeTerm, encodeTreeTerm)
|
||||
import ContentStore.Filesystem (getObject, putObject)
|
||||
import ContentStore.Object (Domain(..), StorePath, ObjectHash)
|
||||
import Research (T(..), ViewRef(..), ViewType(..), pattern VTRef, pattern VTRefText, ofList, ofNumber, ofString, toList, toNumber, toString)
|
||||
|
||||
import Data.Bits (shiftL, shiftR, (.&.))
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
|
||||
import Data.Word (Word8)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Text as T
|
||||
|
||||
viewContractTypeKind :: Text
|
||||
viewContractTypeKind = "arboricx.view-contract.type.v1"
|
||||
|
||||
viewContractTypeDomain :: Domain
|
||||
viewContractTypeDomain = Domain viewContractTypeKind
|
||||
|
||||
encodeViewType :: ViewType -> BS.ByteString
|
||||
encodeViewType = go
|
||||
where
|
||||
go (VTName name) = BS.cons 0x00 (putBytes (encodeUtf8 (T.pack name)))
|
||||
go (VTRefRaw (ViewRefInt n)) = BS.cons 0x01 (putBytes (encodeUtf8 (T.pack ("i:" ++ show n))))
|
||||
go (VTRefRaw (ViewRefText s)) = BS.cons 0x01 (putBytes (encodeUtf8 (T.pack ("s:" ++ s))))
|
||||
go (VTList item) = BS.cons 0x02 (go item)
|
||||
go (VTMaybe item) = BS.cons 0x03 (go item)
|
||||
go (VTPair left right) = BS.cons 0x04 (go left <> go right)
|
||||
go (VTResult err ok) = BS.cons 0x05 (go err <> go ok)
|
||||
go (VTGuarded base guard) = BS.cons 0x07 (go base <> putBytes (encodeTreeTerm guard))
|
||||
go (VTFn args result) =
|
||||
BS.cons 0x06 (putU32 (length args) <> mconcat (map go args) <> go result)
|
||||
|
||||
putViewType :: StorePath -> ViewType -> IO ObjectRef
|
||||
putViewType store view = do
|
||||
h <- putObject store viewContractTypeDomain (encodeViewType view)
|
||||
pure ObjectRef { objectRefKind = viewContractTypeKind, objectRefHash = h }
|
||||
|
||||
getViewType :: StorePath -> ObjectRef -> IO (Either String ViewType)
|
||||
getViewType store ref
|
||||
| objectRefKind ref /= viewContractTypeKind =
|
||||
pure $ Left $ "unsupported View Contract type object kind: " ++ T.unpack (objectRefKind ref)
|
||||
| otherwise = do
|
||||
mPayload <- getObject store (objectRefHash ref)
|
||||
pure $ case mPayload of
|
||||
Nothing -> Left $ "missing View Contract type object: " ++ T.unpack (objectRefHash ref)
|
||||
Just payload -> decodeViewType payload
|
||||
|
||||
decodeViewType :: BS.ByteString -> Either String ViewType
|
||||
decodeViewType payload = do
|
||||
(view, rest) <- getViewTypeBytes payload
|
||||
if BS.null rest
|
||||
then Right view
|
||||
else Left "trailing bytes after View Contract type"
|
||||
|
||||
viewTypeToTree :: ViewType -> T
|
||||
viewTypeToTree view = case view of
|
||||
VTName "Any" -> record 0 []
|
||||
VTName "Bool" -> viewTypeToTree (VTRef 0)
|
||||
VTName "String" -> viewTypeToTree (VTRef 1)
|
||||
VTName "Byte" -> viewTypeToTree (VTRef 2)
|
||||
VTName "Unit" -> viewTypeToTree (VTRef 3)
|
||||
VTName name -> viewTypeToTree (VTRefText name)
|
||||
VTRefRaw ref -> record 2 [field 2 (viewRefToTree ref)]
|
||||
VTList item -> record 3 [field 3 (viewTypeToTree item)]
|
||||
VTMaybe item -> record 4 [field 3 (viewTypeToTree item)]
|
||||
VTPair left right -> record 5 [field 4 (viewTypeToTree left), field 5 (viewTypeToTree right)]
|
||||
VTResult err ok -> record 6 [field 6 (viewTypeToTree err), field 7 (viewTypeToTree ok)]
|
||||
VTGuarded base guard -> record 7 [field 8 (viewTypeToTree base), field 9 guard]
|
||||
VTFn args result -> record 1 [field 0 (ofList (map viewTypeToTree args)), field 1 (viewTypeToTree result)]
|
||||
where
|
||||
record tag fields = Fork (ofNumber tag) (ofList fields)
|
||||
field tag value = Fork (ofNumber tag) value
|
||||
viewRefToTree (ViewRefInt n) = ofNumber n
|
||||
viewRefToTree (ViewRefText s) = ofString s
|
||||
|
||||
treeToViewType :: T -> Either String ViewType
|
||||
treeToViewType viewTree = do
|
||||
(tag, fields) <- recordParts viewTree
|
||||
case tag of
|
||||
0 -> do
|
||||
expectNoFields fields "Any"
|
||||
Right (VTName "Any")
|
||||
1 -> do
|
||||
argsTree <- fieldValueAt 0 fields
|
||||
resultTree <- fieldValueAt 1 fields
|
||||
args <- toList argsTree
|
||||
VTFn <$> mapM treeToViewType args <*> treeToViewType resultTree
|
||||
2 -> VTRefRaw <$> (fieldValueAt 2 fields >>= viewRefFromTree)
|
||||
3 -> VTList <$> (fieldValueAt 3 fields >>= treeToViewType)
|
||||
4 -> VTMaybe <$> (fieldValueAt 3 fields >>= treeToViewType)
|
||||
5 -> VTPair <$> (fieldValueAt 4 fields >>= treeToViewType) <*> (fieldValueAt 5 fields >>= treeToViewType)
|
||||
6 -> VTResult <$> (fieldValueAt 6 fields >>= treeToViewType) <*> (fieldValueAt 7 fields >>= treeToViewType)
|
||||
7 -> VTGuarded <$> (fieldValueAt 8 fields >>= treeToViewType) <*> fieldValueAt 9 fields
|
||||
_ -> Left $ "unknown View Contract view tag in tree: " ++ show tag
|
||||
where
|
||||
recordParts (Fork tagTree fieldsTree) = do
|
||||
tag <- toNumber tagTree
|
||||
fields <- toList fieldsTree
|
||||
pure (tag, fields)
|
||||
recordParts _ = Left "View Contract view tree is not a record"
|
||||
|
||||
expectNoFields fields label =
|
||||
if null fields
|
||||
then Right ()
|
||||
else Left $ "View Contract " ++ label ++ " view has unexpected fields"
|
||||
|
||||
fieldValueAt expectedTag fields = do
|
||||
values <- mapM fieldParts fields
|
||||
case values of
|
||||
[(actualTag, value)] | actualTag == expectedTag -> Right value
|
||||
_ -> case lookup expectedTag values of
|
||||
Just value -> Right value
|
||||
Nothing -> Left $ "View Contract view tree missing field tag: " ++ show expectedTag
|
||||
|
||||
fieldParts (Fork tagTree value) = do
|
||||
tag <- toNumber tagTree
|
||||
pure (tag, value)
|
||||
fieldParts _ = Left "View Contract view field is not a pair"
|
||||
|
||||
viewRefFromTree tree =
|
||||
case toNumber tree of
|
||||
Right n -> Right (ViewRefInt n)
|
||||
Left _ -> ViewRefText <$> toString tree
|
||||
|
||||
getViewTypeBytes :: BS.ByteString -> Either String (ViewType, BS.ByteString)
|
||||
getViewTypeBytes bs = case BS.uncons bs of
|
||||
Nothing -> Left "unexpected end of View Contract type"
|
||||
Just (tag, rest) -> case tag of
|
||||
0x00 -> do
|
||||
(rawName, afterName) <- getBytes rest
|
||||
name <- either (const (Left "View Contract type name is not valid UTF-8")) Right (decodeUtf8' rawName)
|
||||
pure (VTName (T.unpack name), afterName)
|
||||
0x01 -> do
|
||||
(rawRef, afterRef) <- getBytes rest
|
||||
refText <- either (const (Left "View Contract ref is not valid UTF-8")) Right (decodeUtf8' rawRef)
|
||||
ref <- parseViewRef (T.unpack refText)
|
||||
pure (VTRefRaw ref, afterRef)
|
||||
0x02 -> do
|
||||
(item, afterItem) <- getViewTypeBytes rest
|
||||
pure (VTList item, afterItem)
|
||||
0x03 -> do
|
||||
(item, afterItem) <- getViewTypeBytes rest
|
||||
pure (VTMaybe item, afterItem)
|
||||
0x04 -> do
|
||||
(left, afterLeft) <- getViewTypeBytes rest
|
||||
(right, afterRight) <- getViewTypeBytes afterLeft
|
||||
pure (VTPair left right, afterRight)
|
||||
0x05 -> do
|
||||
(err, afterErr) <- getViewTypeBytes rest
|
||||
(ok, afterOk) <- getViewTypeBytes afterErr
|
||||
pure (VTResult err ok, afterOk)
|
||||
0x06 -> do
|
||||
(argc, afterArgc) <- getU32 rest
|
||||
(args, afterArgs) <- getMany argc afterArgc
|
||||
(result, afterResult) <- getViewTypeBytes afterArgs
|
||||
pure (VTFn args result, afterResult)
|
||||
0x07 -> do
|
||||
(base, afterBase) <- getViewTypeBytes rest
|
||||
(rawGuard, afterGuard) <- getBytes afterBase
|
||||
guard <- decodeTreeTerm rawGuard
|
||||
pure (VTGuarded base guard, afterGuard)
|
||||
_ -> Left $ "unknown View Contract type tag: " ++ show tag
|
||||
|
||||
parseViewRef :: String -> Either String ViewRef
|
||||
parseViewRef raw = case raw of
|
||||
'i' : ':' : rest -> ViewRefInt <$> maybe (Left "View Contract integer ref is not an integer") Right (readMaybe rest)
|
||||
's' : ':' : rest -> Right (ViewRefText rest)
|
||||
legacy -> ViewRefInt <$> maybe (Left "View Contract ref is neither tagged nor a legacy integer") Right (readMaybe legacy)
|
||||
|
||||
getMany :: Int -> BS.ByteString -> Either String ([ViewType], BS.ByteString)
|
||||
getMany n bs
|
||||
| n < 0 = Left "negative View Contract argument count"
|
||||
| otherwise = go n bs []
|
||||
where
|
||||
go 0 rest acc = Right (reverse acc, rest)
|
||||
go k rest acc = do
|
||||
(item, afterItem) <- getViewTypeBytes rest
|
||||
go (k - 1) afterItem (item : acc)
|
||||
|
||||
putBytes :: BS.ByteString -> BS.ByteString
|
||||
putBytes bytes = putU32 (BS.length bytes) <> bytes
|
||||
|
||||
getBytes :: BS.ByteString -> Either String (BS.ByteString, BS.ByteString)
|
||||
getBytes bs = do
|
||||
(len, afterLen) <- getU32 bs
|
||||
let (payload, rest) = BS.splitAt len afterLen
|
||||
if BS.length payload == len
|
||||
then Right (payload, rest)
|
||||
else Left "truncated length-prefixed View Contract field"
|
||||
|
||||
putU32 :: Int -> BS.ByteString
|
||||
putU32 n
|
||||
| n < 0 = error "putU32: negative length"
|
||||
| n > 0xffffffff = error "putU32: length too large"
|
||||
| otherwise = BS.pack
|
||||
[ fromIntegral ((n `shiftR` 24) .&. 0xff)
|
||||
, fromIntegral ((n `shiftR` 16) .&. 0xff)
|
||||
, fromIntegral ((n `shiftR` 8) .&. 0xff)
|
||||
, fromIntegral (n .&. 0xff)
|
||||
]
|
||||
|
||||
getU32 :: BS.ByteString -> Either String (Int, BS.ByteString)
|
||||
getU32 bs
|
||||
| BS.length bs < 4 = Left "truncated View Contract u32"
|
||||
| otherwise =
|
||||
let [b0, b1, b2, b3] = BS.unpack (BS.take 4 bs)
|
||||
n = word8ToInt b0 `shiftL` 24
|
||||
+ word8ToInt b1 `shiftL` 16
|
||||
+ word8ToInt b2 `shiftL` 8
|
||||
+ word8ToInt b3
|
||||
in Right (n, BS.drop 4 bs)
|
||||
|
||||
word8ToInt :: Word8 -> Int
|
||||
word8ToInt = fromIntegral
|
||||
135
src/ContentStore/ViewTree.hs
Normal file
135
src/ContentStore/ViewTree.hs
Normal file
@@ -0,0 +1,135 @@
|
||||
module ContentStore.ViewTree
|
||||
( viewTreeKind
|
||||
, viewTreeDomain
|
||||
, encodeViewTree
|
||||
, decodeViewTree
|
||||
, singletonViewTree
|
||||
, viewTreeRootTerm
|
||||
, putViewTree
|
||||
, getViewTree
|
||||
) where
|
||||
|
||||
import ContentStore.Arboricx (decodeTreeTerm, encodeTreeTerm)
|
||||
import ContentStore.Alias (ObjectRef(..))
|
||||
import ContentStore.Filesystem (getObject, putObject)
|
||||
import ContentStore.Object (Domain(..), StorePath)
|
||||
import ContentStore.ViewContract (viewTypeToTree)
|
||||
import Research (T(..), ViewType(..), ofList, ofNumber, toList, toNumber)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Text as T
|
||||
|
||||
viewTreeKind :: T.Text
|
||||
viewTreeKind = "arboricx.view-tree.v1"
|
||||
|
||||
viewTreeDomain :: Domain
|
||||
viewTreeDomain = Domain viewTreeKind
|
||||
|
||||
-- View-tree artifacts are ordinary tree data. Their node envelope semantics
|
||||
-- live in lib/view.tri; this module only provides CAS persistence for the
|
||||
-- portable tree payload.
|
||||
encodeViewTree :: T -> BS.ByteString
|
||||
encodeViewTree = encodeTreeTerm
|
||||
|
||||
decodeViewTree :: BS.ByteString -> Either String T
|
||||
decodeViewTree = decodeTreeTerm
|
||||
|
||||
singletonViewTree :: Maybe ViewType -> T -> T
|
||||
singletonViewTree mView term =
|
||||
record typedProgramTag
|
||||
[ field typedProgramFieldRoot (ofNumber 0)
|
||||
, field typedProgramFieldNodes (ofList [typedValueNode 0 (maybe viewAnyTree viewTypeToTree mView) term])
|
||||
]
|
||||
|
||||
-- | Extract the executable root payload from a view-tree artifact without
|
||||
-- judging view validity. Checker semantics remain in lib/view.tri; this is only
|
||||
-- the module loader's payload projection for imports.
|
||||
viewTreeRootTerm :: T -> Either String T
|
||||
viewTreeRootTerm tree = do
|
||||
tag <- recordTag tree
|
||||
if tag /= typedProgramTag
|
||||
then Left $ "view-tree root has unexpected tag: " ++ show tag
|
||||
else do
|
||||
root <- fieldValue typedProgramFieldRoot tree >>= toNumber
|
||||
nodes <- fieldValue typedProgramFieldNodes tree >>= toList
|
||||
lookupRoot root nodes
|
||||
where
|
||||
lookupRoot _ [] = Left "view-tree root symbol not found"
|
||||
lookupRoot root (node : rest) = do
|
||||
sym <- fieldValue typedNodeFieldSymbol node >>= toNumber
|
||||
if sym == root
|
||||
then nodeTerm node
|
||||
else lookupRoot root rest
|
||||
|
||||
nodeTerm node = do
|
||||
tag <- recordTag node
|
||||
case tag of
|
||||
21 -> fieldValue typedNodeFieldTerm node
|
||||
22 -> fieldValue typedNodeFieldTerm node
|
||||
23 -> fieldValue typedNodeFieldTerm node
|
||||
_ -> Left $ "view-tree node has unexpected tag: " ++ show tag
|
||||
|
||||
record :: Integer -> [T] -> T
|
||||
record tag fields = Fork (ofNumber tag) (ofList fields)
|
||||
|
||||
field :: Integer -> T -> T
|
||||
field tag value = Fork (ofNumber tag) value
|
||||
|
||||
typedValueNode :: Integer -> T -> T -> T
|
||||
typedValueNode sym view term =
|
||||
record typedNodeTagValue
|
||||
[ field typedNodeFieldSymbol (ofNumber sym)
|
||||
, field typedNodeFieldView view
|
||||
, field typedNodeFieldTerm term
|
||||
]
|
||||
|
||||
viewAnyTree :: T
|
||||
viewAnyTree = record 0 []
|
||||
|
||||
recordTag :: T -> Either String Integer
|
||||
recordTag (Fork tagTree _) = toNumber tagTree
|
||||
recordTag _ = Left "view-tree value is not a record"
|
||||
|
||||
recordFields :: T -> Either String [T]
|
||||
recordFields (Fork _ fieldsTree) = toList fieldsTree
|
||||
recordFields _ = Left "view-tree value is not a record"
|
||||
|
||||
fieldValue :: Integer -> T -> Either String T
|
||||
fieldValue expected recordTree = do
|
||||
fields <- recordFields recordTree
|
||||
values <- mapM fieldParts fields
|
||||
case lookup expected values of
|
||||
Just value -> Right value
|
||||
Nothing -> Left $ "view-tree missing field tag: " ++ show expected
|
||||
|
||||
fieldParts :: T -> Either String (Integer, T)
|
||||
fieldParts (Fork tagTree value) = do
|
||||
tag <- toNumber tagTree
|
||||
Right (tag, value)
|
||||
fieldParts _ = Left "view-tree field is not a pair"
|
||||
|
||||
typedProgramTag, typedProgramFieldRoot, typedProgramFieldNodes :: Integer
|
||||
typedProgramTag = 20
|
||||
typedProgramFieldRoot = 0
|
||||
typedProgramFieldNodes = 1
|
||||
|
||||
typedNodeTagValue, typedNodeFieldSymbol, typedNodeFieldView, typedNodeFieldTerm :: Integer
|
||||
typedNodeTagValue = 21
|
||||
typedNodeFieldSymbol = 0
|
||||
typedNodeFieldView = 1
|
||||
typedNodeFieldTerm = 2
|
||||
|
||||
putViewTree :: StorePath -> T -> IO ObjectRef
|
||||
putViewTree store viewTree = do
|
||||
h <- putObject store viewTreeDomain (encodeViewTree viewTree)
|
||||
pure ObjectRef { objectRefKind = viewTreeKind, objectRefHash = h }
|
||||
|
||||
getViewTree :: StorePath -> ObjectRef -> IO (Either String T)
|
||||
getViewTree store ref
|
||||
| objectRefKind ref /= viewTreeKind =
|
||||
pure $ Left $ "unsupported view-tree object kind: " ++ T.unpack (objectRefKind ref)
|
||||
| otherwise = do
|
||||
mPayload <- getObject store (objectRefHash ref)
|
||||
pure $ case mPayload of
|
||||
Nothing -> Left $ "missing view-tree object: " ++ T.unpack (objectRefHash ref)
|
||||
Just payload -> decodeViewTree payload
|
||||
135
src/Eval.hs
135
src/Eval.hs
@@ -1,20 +1,16 @@
|
||||
module Eval where
|
||||
|
||||
import ContentStore
|
||||
import Parser
|
||||
import Research
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Data.List (partition, (\\), elemIndex, foldl')
|
||||
import Data.Map ()
|
||||
import Data.Set (Set)
|
||||
import Database.SQLite.Simple
|
||||
import Debug.Trace (trace)
|
||||
|
||||
import qualified Data.Foldable as F ()
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
|
||||
data DB
|
||||
= BVar Int
|
||||
@@ -43,6 +39,16 @@ evalSingle env term
|
||||
-> Map.insert "!result" res (Map.insert name res env)
|
||||
Nothing
|
||||
-> Map.insert "!result" res (Map.insert name res env)
|
||||
| SDefAnn name args _ body <- term
|
||||
= let params = annotatedBinders args
|
||||
res = evalASTSync env (if null params then body else SLambda params body)
|
||||
in case Map.lookup name env of
|
||||
Just existingValue
|
||||
| existingValue == res -> env
|
||||
| otherwise
|
||||
-> Map.insert "!result" res (Map.insert name res env)
|
||||
Nothing
|
||||
-> Map.insert "!result" res (Map.insert name res env)
|
||||
| SApp func arg <- term
|
||||
= let res = apply (evalASTSync env func) (evalASTSync env arg)
|
||||
in Map.insert "!result" res env
|
||||
@@ -87,94 +93,17 @@ evalASTSync env term = case term of
|
||||
SEmpty -> Leaf
|
||||
_ -> errorWithoutStackTrace $ "Unexpected AST term: " ++ show term
|
||||
|
||||
evalAST :: Maybe Connection -> Map.Map String T.Text -> TricuAST -> IO T
|
||||
evalAST mconn selectedVersions ast = do
|
||||
let varNames = collectVarNames ast
|
||||
resolvedEnv <- resolveTermsFromStore mconn selectedVersions varNames
|
||||
return $ evalASTSync resolvedEnv ast
|
||||
|
||||
-- | Evaluate a single AST term using a local environment augmented by
|
||||
-- lazily-resolved store terms.
|
||||
evalASTWithEnv :: Maybe Connection -> Env -> TricuAST -> IO T
|
||||
evalASTWithEnv mconn localEnv ast = do
|
||||
let varNames = collectVarNames ast
|
||||
storeEnv <- resolveTermsFromStore mconn Map.empty varNames
|
||||
let combinedEnv = Map.union localEnv storeEnv
|
||||
return $ evalASTSync combinedEnv ast
|
||||
|
||||
evalSingleWithStore :: Maybe Connection -> Env -> TricuAST -> IO Env
|
||||
evalSingleWithStore mconn env term
|
||||
| SDef name params body <- term = do
|
||||
res <- evalASTWithEnv mconn env (if null params then body else SLambda params body)
|
||||
case Map.lookup name env of
|
||||
Just existingValue
|
||||
| existingValue == res -> return env
|
||||
| otherwise -> return $ Map.insert "!result" res (Map.insert name res env)
|
||||
Nothing -> return $ Map.insert "!result" res (Map.insert name res env)
|
||||
| otherwise = do
|
||||
res <- evalASTWithEnv mconn env term
|
||||
return $ Map.insert "!result" res env
|
||||
|
||||
evalTricuWithStore :: Maybe Connection -> Env -> [TricuAST] -> IO Env
|
||||
evalTricuWithStore mconn env x = go env (reorderDefs env (map recoverParams x))
|
||||
where
|
||||
go env' [] = return env'
|
||||
go env' [def] = do
|
||||
updatedEnv <- evalSingleWithStore mconn env' def
|
||||
return $ Map.insert "!result" (result updatedEnv) updatedEnv
|
||||
go env' (def:xs) = do
|
||||
updatedEnv <- evalSingleWithStore mconn env' def
|
||||
evalTricuWithStore mconn updatedEnv xs
|
||||
evalAST :: Env -> TricuAST -> IO T
|
||||
evalAST env ast = return $ evalASTSync env ast
|
||||
|
||||
recoverParams :: TricuAST -> TricuAST
|
||||
recoverParams (SDef name [] (SLambda params body)) = SDef name params body
|
||||
recoverParams term = term
|
||||
|
||||
collectVarNames :: TricuAST -> [(String, Maybe String)]
|
||||
collectVarNames = go []
|
||||
where
|
||||
go acc (SVar name mhash) = (name, mhash) : acc
|
||||
go acc (SApp t u) = go (go acc t) u
|
||||
go acc (SLambda vars body) =
|
||||
let boundVars = Set.fromList vars
|
||||
collected = go [] body
|
||||
in acc ++ filter (\(name, _) -> not $ Set.member name boundVars) collected
|
||||
go acc (TStem t) = go acc t
|
||||
go acc (TFork t u) = go (go acc t) u
|
||||
go acc (SList xs) = foldl' go acc xs
|
||||
go acc _ = acc
|
||||
|
||||
resolveTermsFromStore :: Maybe Connection -> Map.Map String T.Text -> [(String, Maybe String)] -> IO Env
|
||||
resolveTermsFromStore Nothing _ _ = return Map.empty
|
||||
resolveTermsFromStore (Just conn) selectedVersions varNames = do
|
||||
foldM (\env (name, mhash) -> do
|
||||
term <- resolveTermFromStore conn selectedVersions name mhash
|
||||
case term of
|
||||
Just t -> return $ Map.insert (getVarKey name mhash) t env
|
||||
Nothing -> return env
|
||||
) Map.empty varNames
|
||||
where
|
||||
getVarKey name Nothing = name
|
||||
getVarKey name (Just hash) = name ++ "#" ++ hash
|
||||
|
||||
resolveTermFromStore :: Connection -> Map.Map String T.Text -> String -> Maybe String -> IO (Maybe T)
|
||||
resolveTermFromStore conn selectedVersions name mhash = case mhash of
|
||||
Just hashPrefix -> do
|
||||
versions <- termVersions conn name
|
||||
let matchingVersions = filter (\(hash, _, _) ->
|
||||
T.isPrefixOf (T.pack hashPrefix) hash) versions
|
||||
case matchingVersions of
|
||||
[] -> return Nothing
|
||||
[(_, term, _)] -> return $ Just term
|
||||
_ -> return Nothing
|
||||
Nothing -> case Map.lookup name selectedVersions of
|
||||
Just hash -> loadTree conn hash
|
||||
Nothing -> do
|
||||
versions <- termVersions conn name
|
||||
case versions of
|
||||
[] -> return Nothing
|
||||
[(_, term, _)] -> return $ Just term
|
||||
_ -> return $ Just (head (map (\(_, t, _) -> t) versions))
|
||||
annotatedBinders :: [DefArg] -> [String]
|
||||
annotatedBinders [] = []
|
||||
annotatedBinders (DefBinder name _ : rest) = name : annotatedBinders rest
|
||||
annotatedBinders (DefPhantom _ : rest) = annotatedBinders rest
|
||||
|
||||
elimLambda :: TricuAST -> TricuAST
|
||||
elimLambda = go
|
||||
@@ -262,6 +191,7 @@ freeVars (SVar v (Just _)) = Set.singleton v
|
||||
freeVars (SApp t u) = Set.union (freeVars t) (freeVars u)
|
||||
freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs)
|
||||
freeVars (SDef _ params body) = Set.difference (freeVars body) (Set.fromList params)
|
||||
freeVars (SDefAnn _ args _ body) = Set.difference (freeVars body) (Set.fromList (annotatedBinders args))
|
||||
freeVars (TStem t) = freeVars t
|
||||
freeVars (TFork t u) = Set.union (freeVars t) (freeVars u)
|
||||
freeVars (SList xs) = foldMap freeVars xs
|
||||
@@ -275,13 +205,13 @@ reorderDefs env defs
|
||||
| otherwise = orderedDefs ++ others
|
||||
where
|
||||
(defsOnly, others) = partition isDef defs
|
||||
defNames = [ name | SDef name _ _ <- defsOnly ]
|
||||
defNames = [ defName def | def <- defsOnly ]
|
||||
|
||||
defsWithFreeVars = [(def, freeVars def) | def <- defsOnly]
|
||||
|
||||
graph = buildDepGraph defsOnly
|
||||
sortedDefs = sortDeps graph
|
||||
defMap = Map.fromList [(name, def) | def@(SDef name _ _) <- defsOnly]
|
||||
defMap = Map.fromList [(defName def, def) | def <- defsOnly]
|
||||
orderedDefs = map (defMap Map.!) sortedDefs
|
||||
|
||||
freeVarsDefs = foldMap snd defsWithFreeVars
|
||||
@@ -291,6 +221,7 @@ reorderDefs env defs
|
||||
missingDeps = Set.toList (allFreeVars `Set.difference` validNames)
|
||||
|
||||
isDef SDef {} = True
|
||||
isDef SDefAnn {} = True
|
||||
isDef _ = False
|
||||
|
||||
buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String)
|
||||
@@ -300,11 +231,11 @@ buildDepGraph topDefs
|
||||
"Conflicting definitions detected: " ++ show conflictingDefs
|
||||
| otherwise =
|
||||
Map.fromList
|
||||
[ (name, depends topDefs def)
|
||||
| def@(SDef name _ _) <- topDefs]
|
||||
[ (defName def, depends topDefs def)
|
||||
| def <- topDefs]
|
||||
where
|
||||
defsMap = Map.fromListWith (++)
|
||||
[(name, [(name, body)]) | SDef name _ body <- topDefs]
|
||||
[(defName def, [(defName def, defBody def)]) | def <- topDefs]
|
||||
|
||||
conflictingDefs =
|
||||
[ name
|
||||
@@ -330,10 +261,24 @@ sortDeps graph = go [] Set.empty (Map.keys graph)
|
||||
(Set.union sortedSet (Set.fromList ready))
|
||||
notReady
|
||||
|
||||
defName :: TricuAST -> String
|
||||
defName (SDef name _ _) = name
|
||||
defName (SDefAnn name _ _ _) = name
|
||||
defName _ = error "defName: expected definition"
|
||||
|
||||
defBody :: TricuAST -> TricuAST
|
||||
defBody (SDef _ _ body) = body
|
||||
defBody (SDefAnn _ _ _ body) = body
|
||||
defBody _ = error "defBody: expected definition"
|
||||
|
||||
depends :: [TricuAST] -> TricuAST -> Set.Set String
|
||||
depends topDefs def@(SDef _ _ _) =
|
||||
depends topDefs def@SDef {} =
|
||||
Set.intersection
|
||||
(Set.fromList [n | SDef n _ _ <- topDefs])
|
||||
(Set.fromList [defName d | d <- topDefs])
|
||||
(freeVars def)
|
||||
depends topDefs def@SDefAnn {} =
|
||||
Set.intersection
|
||||
(Set.fromList [defName d | d <- topDefs])
|
||||
(freeVars def)
|
||||
depends _ _ = Set.empty
|
||||
|
||||
@@ -353,6 +298,7 @@ findVarNames ast = case ast of
|
||||
SApp a b -> findVarNames a ++ findVarNames b
|
||||
SLambda args body -> findVarNames body \\ args
|
||||
SDef name args body -> name : (findVarNames body \\ args)
|
||||
SDefAnn name args _ body -> name : (findVarNames body \\ annotatedBinders args)
|
||||
_ -> []
|
||||
|
||||
-- Convert named TricuAST to De Bruijn form
|
||||
@@ -372,6 +318,7 @@ toDB env = \case
|
||||
SList xs -> BList (map (toDB env) xs)
|
||||
SEmpty -> BEmpty
|
||||
SDef{} -> error "toDB: unexpected SDef at this stage"
|
||||
SDefAnn{} -> error "toDB: unexpected SDefAnn at this stage"
|
||||
SImport _ _ -> BEmpty
|
||||
|
||||
-- Does a term depend on the current binder (level 0)?
|
||||
|
||||
370
src/FileEval.hs
370
src/FileEval.hs
@@ -1,22 +1,41 @@
|
||||
module FileEval
|
||||
( preprocessFile
|
||||
( ContractMode(..)
|
||||
, LoadedSource(..)
|
||||
, preprocessFile
|
||||
, preprocessFileWithStore
|
||||
, preprocessFileWithResolver
|
||||
, evaluateFile
|
||||
, evaluateFileWithContext
|
||||
, evaluateFileWithStore
|
||||
, evaluateFileWithContext
|
||||
, evaluateFileWithContextWithStore
|
||||
, evaluateFileWithContextWithStoreAndMode
|
||||
, evaluateFileResult
|
||||
, compileFile
|
||||
, compileFileWithStore
|
||||
, loadFileWithStore
|
||||
, loadFileWithStoreMode
|
||||
, defaultStorePath
|
||||
) where
|
||||
|
||||
import Eval (evalTricu, evalTricuWithStore)
|
||||
import Check.Core
|
||||
( checkProgramWithEnvAndImportedViews
|
||||
, importedViewsFromResolvedModulesEither
|
||||
, lowerViewExpr
|
||||
)
|
||||
import ContentStore
|
||||
import Eval (evalASTSync, evalTricu, freeVars, result)
|
||||
import Lexer
|
||||
import Module.Manifest
|
||||
import Module.Resolver
|
||||
import Module.Workspace
|
||||
import Parser
|
||||
import Research
|
||||
import Wire (buildBundle, encodeBundle, decodeBundle, verifyBundle, Bundle(..))
|
||||
import Database.SQLite.Simple (Connection)
|
||||
|
||||
import Data.List (partition)
|
||||
import Data.List (partition, isPrefixOf)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import System.FilePath (takeDirectory, normalise, (</>))
|
||||
import System.Directory (getHomeDirectory, getTemporaryDirectory)
|
||||
import System.FilePath ((</>))
|
||||
import System.Exit (die)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
@@ -32,153 +51,262 @@ extractMain env =
|
||||
Just evalResult -> Right evalResult
|
||||
Nothing -> Left "No `main` function detected"
|
||||
|
||||
processImports :: Set.Set FilePath -> FilePath -> FilePath -> [TricuAST]
|
||||
-> Either String ([TricuAST], [(FilePath, String, FilePath)])
|
||||
processImports seen _base currentPath asts =
|
||||
data ContractMode
|
||||
= EnforceContracts
|
||||
| IgnoreContracts
|
||||
deriving (Eq, Show)
|
||||
|
||||
data LoadedSource = LoadedSource
|
||||
{ loadedImports :: Env
|
||||
, loadedAst :: [TricuAST]
|
||||
, loadedModules :: [ResolvedModule]
|
||||
}
|
||||
|
||||
data LoadContext = LoadContext
|
||||
{ loadResolver :: ObjectResolver
|
||||
, loadStore :: Maybe StorePath
|
||||
, loadWorkspace :: Workspace
|
||||
, loadContracts :: ContractMode
|
||||
}
|
||||
|
||||
processImports :: [TricuAST] -> ([TricuAST], [(String, String)])
|
||||
processImports asts =
|
||||
let (imports, nonImports) = partition isImp asts
|
||||
importPaths = mapMaybe getImportInfo imports
|
||||
in if currentPath `Set.member` seen
|
||||
then Left $ "Encountered cyclic import: " ++ currentPath
|
||||
else Right (nonImports, importPaths)
|
||||
importTargets = mapMaybe getImportInfo imports
|
||||
in (nonImports, importTargets)
|
||||
where
|
||||
isImp (SImport _ _) = True
|
||||
isImp _ = False
|
||||
getImportInfo (SImport p n) = Just (p, n, makeRelativeTo currentPath p)
|
||||
getImportInfo (SImport p n) = Just (p, n)
|
||||
getImportInfo _ = Nothing
|
||||
|
||||
evaluateFileResult :: FilePath -> IO T
|
||||
evaluateFileResult filePath = do
|
||||
contents <- readFile filePath
|
||||
let tokens = lexTricu contents
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError tokens err)
|
||||
Right _ast -> do
|
||||
processedAst <- preprocessFile filePath
|
||||
let finalEnv = evalTricu Map.empty processedAst
|
||||
case extractMain finalEnv of
|
||||
Right evalResult -> return evalResult
|
||||
Left err -> errorWithoutStackTrace err
|
||||
env <- evaluateFile filePath
|
||||
case extractMain env of
|
||||
Right evalResult -> return evalResult
|
||||
Left err -> errorWithoutStackTrace err
|
||||
|
||||
evaluateFile :: FilePath -> IO Env
|
||||
evaluateFile filePath = do
|
||||
contents <- readFile filePath
|
||||
let tokens = lexTricu contents
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError tokens err)
|
||||
Right _ast -> do
|
||||
ast <- preprocessFile filePath
|
||||
pure $ evalTricu Map.empty ast
|
||||
evaluateFile = evaluateFileWithStore Nothing
|
||||
|
||||
evaluateFileWithStore :: Maybe StorePath -> FilePath -> IO Env
|
||||
evaluateFileWithStore mStore filePath = do
|
||||
loaded <- maybe loadFile loadFileWithStore mStore filePath
|
||||
pure $ evalTricu (loadedImports loaded) (loadedAst loaded)
|
||||
|
||||
evaluateFileWithContext :: Env -> FilePath -> IO Env
|
||||
evaluateFileWithContext env filePath = do
|
||||
contents <- readFile filePath
|
||||
let tokens = lexTricu contents
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError tokens err)
|
||||
Right _ast -> do
|
||||
ast <- preprocessFile filePath
|
||||
pure $ evalTricu env ast
|
||||
evaluateFileWithContext = evaluateFileWithContextWithStore Nothing
|
||||
|
||||
-- | File evaluation that lazily resolves missing names from the
|
||||
-- content store instead of pre-loading the entire store into memory.
|
||||
evaluateFileWithStore :: Maybe Connection -> Env -> FilePath -> IO Env
|
||||
evaluateFileWithStore mconn env filePath = do
|
||||
contents <- readFile filePath
|
||||
let tokens = lexTricu contents
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError tokens err)
|
||||
Right _ast -> do
|
||||
ast <- preprocessFile filePath
|
||||
evalTricuWithStore mconn env ast
|
||||
evaluateFileWithContextWithStore :: Maybe StorePath -> Env -> FilePath -> IO Env
|
||||
evaluateFileWithContextWithStore mStore =
|
||||
evaluateFileWithContextWithStoreAndMode EnforceContracts mStore
|
||||
|
||||
evaluateFileWithContextWithStoreAndMode :: ContractMode -> Maybe StorePath -> Env -> FilePath -> IO Env
|
||||
evaluateFileWithContextWithStoreAndMode mode mStore env filePath = do
|
||||
loaded <- case mStore of
|
||||
Nothing -> loadFileMode mode filePath
|
||||
Just store -> loadFileWithStoreMode mode store filePath
|
||||
pure $ evalTricu (Map.union (loadedImports loaded) env) (loadedAst loaded)
|
||||
|
||||
preprocessFile :: FilePath -> IO [TricuAST]
|
||||
preprocessFile p = preprocessFile' Set.empty p p
|
||||
preprocessFile p = loadedAst <$> loadFile p
|
||||
|
||||
preprocessFile' :: Set.Set FilePath -> FilePath -> FilePath -> IO [TricuAST]
|
||||
preprocessFile' seen base currentPath = do
|
||||
preprocessFileWithStore :: StorePath -> FilePath -> IO [TricuAST]
|
||||
preprocessFileWithStore store p = loadedAst <$> loadFileWithStore store p
|
||||
|
||||
preprocessFileWithResolver :: ObjectResolver -> FilePath -> IO [TricuAST]
|
||||
preprocessFileWithResolver resolver p = loadedAst <$> loadFileWithResolver resolver p
|
||||
|
||||
loadFile :: FilePath -> IO LoadedSource
|
||||
loadFile = loadFileMode EnforceContracts
|
||||
|
||||
loadFileMode :: ContractMode -> FilePath -> IO LoadedSource
|
||||
loadFileMode mode p = do
|
||||
store <- defaultStorePath
|
||||
loadFileWithStoreMode mode store p
|
||||
|
||||
loadFileWithStore :: StorePath -> FilePath -> IO LoadedSource
|
||||
loadFileWithStore = loadFileWithStoreMode EnforceContracts
|
||||
|
||||
loadFileWithStoreMode :: ContractMode -> StorePath -> FilePath -> IO LoadedSource
|
||||
loadFileWithStoreMode mode store p = do
|
||||
workspace <- findWorkspaceFor p
|
||||
resolver <- cachedFilesystemResolver store
|
||||
let ctx = LoadContext resolver (Just store) workspace mode
|
||||
loadFile' ctx p
|
||||
|
||||
loadFileWithResolver :: ObjectResolver -> FilePath -> IO LoadedSource
|
||||
loadFileWithResolver resolver p = do
|
||||
let ctx = LoadContext resolver Nothing emptyWorkspace EnforceContracts
|
||||
loadFile' ctx p
|
||||
|
||||
loadFile' :: LoadContext -> FilePath -> IO LoadedSource
|
||||
loadFile' ctx currentPath = do
|
||||
contents <- readFile currentPath
|
||||
let tokens = lexTricu contents
|
||||
case parseProgram tokens of
|
||||
Left err -> errorWithoutStackTrace (handleParseError tokens err)
|
||||
Right ast ->
|
||||
case processImports seen base currentPath ast of
|
||||
Left err -> errorWithoutStackTrace err
|
||||
Right (nonImports, importPaths) -> do
|
||||
let seen' = Set.insert currentPath seen
|
||||
imported <- concat <$> mapM (processImportPath seen' base) importPaths
|
||||
pure $ imported ++ nonImports
|
||||
let (nonImports, importTargets) = processImports ast
|
||||
in do
|
||||
let reexportOnlyModule = null (topLevelDefinitions nonImports) && not (null importTargets)
|
||||
resolvedModules <- mapM (\(target, name) -> do
|
||||
ensureWorkspaceModule ctx target
|
||||
resolveModuleImportSelecting (loadResolver ctx) (selectedExportsForImport reexportOnlyModule target name nonImports) target name) importTargets
|
||||
let moduleEnv = resolvedModulesEnv resolvedModules
|
||||
pure LoadedSource
|
||||
{ loadedImports = moduleEnv
|
||||
, loadedAst = nonImports
|
||||
, loadedModules = resolvedModules
|
||||
}
|
||||
|
||||
ensureWorkspaceModule :: LoadContext -> String -> IO ()
|
||||
ensureWorkspaceModule ctx moduleTarget = do
|
||||
existing <- resolverAlias (loadResolver ctx) ModuleAlias (T.pack moduleTarget)
|
||||
case existing of
|
||||
Just _ -> return ()
|
||||
Nothing -> do
|
||||
mSource <- resolveSourceModulePath ctx moduleTarget
|
||||
case (loadStore ctx, mSource) of
|
||||
(Just store, Just sourcePath) -> buildWorkspaceModule ctx store moduleTarget sourcePath
|
||||
_ -> return ()
|
||||
|
||||
resolveSourceModulePath :: LoadContext -> String -> IO (Maybe FilePath)
|
||||
resolveSourceModulePath ctx moduleTarget =
|
||||
return (lookupWorkspaceModule (loadWorkspace ctx) (T.pack moduleTarget))
|
||||
|
||||
buildWorkspaceModule :: LoadContext -> StorePath -> String -> FilePath -> IO ()
|
||||
buildWorkspaceModule ctx store moduleName sourcePath = do
|
||||
loaded <- loadFile' ctx sourcePath
|
||||
let asts = loadedAst loaded
|
||||
case loadContracts ctx of
|
||||
EnforceContracts -> enforceWorkspaceModuleContracts store moduleName (loadedImports loaded) (loadedModules loaded) asts
|
||||
IgnoreContracts -> pure ()
|
||||
let env = evalTricu (loadedImports loaded) asts
|
||||
localNames = topLevelDefinitions asts
|
||||
localViewExprs = topLevelDefinitionViews asts
|
||||
localViews = case loadContracts ctx of
|
||||
EnforceContracts
|
||||
| Map.null localViewExprs -> pure (Right Map.empty)
|
||||
| otherwise -> do
|
||||
viewEnv <- evaluateFileWithContextWithStoreAndMode IgnoreContracts (Just store) Map.empty "./lib/view.tri"
|
||||
let checkerEnv = evalTricu (Map.union viewEnv (loadedImports loaded)) asts
|
||||
pure (resolveDefinitionViews checkerEnv localViewExprs)
|
||||
IgnoreContracts -> pure (Right Map.empty)
|
||||
names = if null localNames
|
||||
then filter (/= "!result") (Map.keys env)
|
||||
else localNames
|
||||
localViewsResult <- localViews
|
||||
resolvedLocalViews <- either (errorWithoutStackTrace . (("Workspace module " ++ show moduleName ++ " has invalid exported View Contract annotation: ") ++)) pure localViewsResult
|
||||
exports <- mapM (buildExport env resolvedLocalViews) names
|
||||
manifestHash <- putManifest store (ModuleManifest [] exports)
|
||||
writeAlias store ModuleAlias (T.pack moduleName) (ObjectRef (unDomain manifestDomain) manifestHash)
|
||||
where
|
||||
processImportPath _seen _base (_path, name, importPath) = do
|
||||
ast <- preprocessFile' _seen _base importPath
|
||||
pure $ map (nsDefinition (if name == "!Local" then "" else name))
|
||||
$ filter (not . isImp) ast
|
||||
isImp (SImport _ _) = True
|
||||
isImp _ = False
|
||||
buildExport env localViews name = case Map.lookup name env of
|
||||
Nothing -> errorWithoutStackTrace $ "Workspace module export not found after evaluation: " ++ name
|
||||
Just term -> do
|
||||
let exportView = Map.lookup name localViews
|
||||
rootRef <- putViewTree store (singletonViewTree exportView term)
|
||||
viewRef <- mapM (putViewType store) exportView
|
||||
return ModuleExport
|
||||
{ moduleExportName = T.pack name
|
||||
, moduleExportObject = rootRef
|
||||
, moduleExportAbi = "arboricx.abi.view-tree.v1"
|
||||
, moduleExportView = viewRef
|
||||
}
|
||||
|
||||
makeRelativeTo :: FilePath -> FilePath -> FilePath
|
||||
makeRelativeTo f i =
|
||||
let d = takeDirectory f
|
||||
in normalise $ d </> i
|
||||
enforceWorkspaceModuleContracts :: StorePath -> String -> Env -> [ResolvedModule] -> [TricuAST] -> IO ()
|
||||
enforceWorkspaceModuleContracts store moduleName importEnv modules asts
|
||||
| not (any isAnnotatedDefinition asts) = pure ()
|
||||
| otherwise = do
|
||||
viewEnv <- evaluateFileWithContextWithStoreAndMode IgnoreContracts (Just store) Map.empty "./lib/view.tri"
|
||||
let checkerEnv = evalTricu (Map.union viewEnv importEnv) asts
|
||||
imports <- importedViewsFromResolvedModulesEither (getViewType store) modules
|
||||
resultText <- checkProgramWithEnvAndImportedViews checkerEnv imports asts
|
||||
case resultText of
|
||||
"ok" -> pure ()
|
||||
diagnostic -> errorWithoutStackTrace $
|
||||
"Workspace module " ++ show moduleName ++ " failed View Contract check: " ++ diagnostic
|
||||
|
||||
nsDefinition :: String -> TricuAST -> TricuAST
|
||||
nsDefinition "" def = def
|
||||
nsDefinition moduleName (SDef name args body)
|
||||
| isPrefixed name = SDef name args (nsBody moduleName body)
|
||||
| otherwise = SDef (nsVariable moduleName name)
|
||||
args (nsBody moduleName body)
|
||||
nsDefinition moduleName other =
|
||||
nsBody moduleName other
|
||||
isAnnotatedDefinition :: TricuAST -> Bool
|
||||
isAnnotatedDefinition SDefAnn {} = True
|
||||
isAnnotatedDefinition _ = False
|
||||
|
||||
nsBody :: String -> TricuAST -> TricuAST
|
||||
nsBody moduleName (SVar name mhash)
|
||||
| isPrefixed name = SVar name mhash
|
||||
| otherwise = SVar (nsVariable moduleName name) mhash
|
||||
nsBody moduleName (SApp func arg) =
|
||||
SApp (nsBody moduleName func) (nsBody moduleName arg)
|
||||
nsBody moduleName (SLambda args body) =
|
||||
SLambda args (nsBodyScoped moduleName args body)
|
||||
nsBody moduleName (SList items) =
|
||||
SList (map (nsBody moduleName) items)
|
||||
nsBody moduleName (TFork left right) =
|
||||
TFork (nsBody moduleName left) (nsBody moduleName right)
|
||||
nsBody moduleName (TStem subtree) =
|
||||
TStem (nsBody moduleName subtree)
|
||||
nsBody moduleName (SDef name args body) =
|
||||
SDef (nsVariable moduleName name) args (nsBodyScoped moduleName args body)
|
||||
nsBody _ other = other
|
||||
topLevelDefinitions :: [TricuAST] -> [String]
|
||||
topLevelDefinitions = mapMaybe go
|
||||
where
|
||||
go (SDef name _ _) = Just name
|
||||
go (SDefAnn name _ _ _) = Just name
|
||||
go _ = Nothing
|
||||
|
||||
nsBodyScoped :: String -> [String] -> TricuAST -> TricuAST
|
||||
nsBodyScoped moduleName args body = case body of
|
||||
SVar name mhash ->
|
||||
if name `elem` args
|
||||
then SVar name mhash
|
||||
else nsBody moduleName (SVar name mhash)
|
||||
SApp func arg ->
|
||||
SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg)
|
||||
SLambda innerArgs innerBody ->
|
||||
SLambda innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
|
||||
SList items ->
|
||||
SList (map (nsBodyScoped moduleName args) items)
|
||||
TFork left right ->
|
||||
TFork (nsBodyScoped moduleName args left) (nsBodyScoped moduleName args right)
|
||||
TStem subtree ->
|
||||
TStem (nsBodyScoped moduleName args subtree)
|
||||
SDef name innerArgs innerBody ->
|
||||
SDef (nsVariable moduleName name) innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
|
||||
other -> other
|
||||
topLevelDefinitionViews :: [TricuAST] -> Map.Map String ViewExpr
|
||||
topLevelDefinitionViews asts = Map.fromList (mapMaybe go asts)
|
||||
where
|
||||
go (SDefAnn name args resultView _) = Just (name, definitionView args resultView)
|
||||
go _ = Nothing
|
||||
|
||||
isPrefixed :: String -> Bool
|
||||
isPrefixed name = '.' `elem` name
|
||||
resolveDefinitionViews :: Env -> Map.Map String ViewExpr -> Either String (Map.Map String ViewType)
|
||||
resolveDefinitionViews env = mapM (resolveViewExpression env)
|
||||
|
||||
nsVariable :: String -> String -> String
|
||||
nsVariable "" name = name
|
||||
nsVariable moduleName name = moduleName ++ "." ++ name
|
||||
resolveViewExpression :: Env -> ViewExpr -> Either String ViewType
|
||||
resolveViewExpression checkerEnv view = do
|
||||
expr <- lowerViewExpr view
|
||||
let term = evalASTSync checkerEnv (head (parseTricu expr))
|
||||
probeEnv = Map.insert "__candidateView" term checkerEnv
|
||||
probe = evalTricu probeEnv (parseTricu "viewContractProbe (wellFormedView? __candidateView)")
|
||||
case toString (result probe) of
|
||||
Right "ok" -> treeToViewType term
|
||||
Right other -> Left $ "malformed view expression " ++ show expr ++ ": " ++ other
|
||||
Left err -> Left $ "could not validate view expression " ++ show expr ++ ": " ++ err
|
||||
|
||||
definitionView :: [DefArg] -> Maybe ViewExpr -> ViewExpr
|
||||
definitionView args resultView =
|
||||
case argViews of
|
||||
[] -> finalView
|
||||
_ -> VEApp (VEApp (VEName "Fn") (VEList argViews)) finalView
|
||||
where
|
||||
argViews = map defArgView args
|
||||
finalView = maybe exportedViewAny id resultView
|
||||
|
||||
defArgView :: DefArg -> ViewExpr
|
||||
defArgView (DefBinder _ Nothing) = exportedViewAny
|
||||
defArgView (DefBinder _ (Just ty)) = ty
|
||||
defArgView (DefPhantom ty) = ty
|
||||
|
||||
exportedViewAny :: ViewExpr
|
||||
exportedViewAny = VEName "Any"
|
||||
|
||||
defaultStorePath :: IO StorePath
|
||||
defaultStorePath = do
|
||||
home <- getHomeDirectory
|
||||
if home == "/homeless-shelter"
|
||||
then do
|
||||
tmp <- getTemporaryDirectory
|
||||
return (StorePath (tmp </> "tricu" </> "store"))
|
||||
else return (StorePath (home </> ".tricu" </> "store"))
|
||||
|
||||
selectedExportsForImport :: Bool -> String -> String -> [TricuAST] -> Maybe (Set.Set T.Text)
|
||||
selectedExportsForImport True _ _ _ = Nothing
|
||||
selectedExportsForImport False _moduleTarget namespace asts =
|
||||
Just $ Set.fromList directSelections
|
||||
where
|
||||
directSelections = mapMaybe select (Set.toList used)
|
||||
used = foldMap freeVars asts
|
||||
prefix = namespace ++ "."
|
||||
select name
|
||||
| namespace == "!Local" = Just (T.pack name)
|
||||
| prefix `isPrefixOf` name = Just (T.pack (drop (length prefix) name))
|
||||
| otherwise = Nothing
|
||||
|
||||
-- | Compile a tricu source file to a standalone Arboricx bundle.
|
||||
-- Emits a canonical indexed bundle with no SHA-256 hashing.
|
||||
compileFile :: FilePath -> FilePath -> [T.Text] -> IO ()
|
||||
compileFile inputPath outputPath maybeNames = do
|
||||
env <- evaluateFile inputPath
|
||||
compileFile = compileFileWithStore Nothing
|
||||
|
||||
compileFileWithStore :: Maybe StorePath -> FilePath -> FilePath -> [T.Text] -> IO ()
|
||||
compileFileWithStore mStore inputPath outputPath maybeNames = do
|
||||
env <- evaluateFileWithStore mStore inputPath
|
||||
let defaultNames = ["main"]
|
||||
wantedNames = if null maybeNames then defaultNames else maybeNames
|
||||
wantedNamesUnpacked = map T.unpack wantedNames
|
||||
|
||||
38
src/Lexer.hs
38
src/Lexer.hs
@@ -33,14 +33,16 @@ tricuLexer = do
|
||||
tricuLexer' =
|
||||
[ try lnewline
|
||||
, try indentMarker
|
||||
, try namespace
|
||||
, try dot
|
||||
, try identifierWithHash
|
||||
, try identifier
|
||||
, try keywordT
|
||||
, try identifier
|
||||
, try namespace
|
||||
, try integerLiteral
|
||||
, try stringLiteral
|
||||
, try assignAt
|
||||
, assign
|
||||
, atSign
|
||||
, colon
|
||||
, openParen
|
||||
, closeParen
|
||||
@@ -81,10 +83,10 @@ keywordT = string "t" *> notFollowedBy alphaNumChar $> LKeywordT
|
||||
|
||||
identifierWithHash :: Lexer LToken
|
||||
identifierWithHash = do
|
||||
first <- lowerChar <|> char '_'
|
||||
first <- letterChar <|> char '_'
|
||||
rest <- many $ letterChar
|
||||
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
|
||||
<|> char '$' <|> char '@' <|> char '%'
|
||||
<|> char '$' <|> char '%'
|
||||
<|> char '\''
|
||||
_ <- char '#' -- Consume '#'
|
||||
hashString <- some (alphaNumChar <|> char '-') -- Ensures at least one char for hash
|
||||
@@ -103,10 +105,10 @@ identifierWithHash = do
|
||||
|
||||
identifier :: Lexer LToken
|
||||
identifier = do
|
||||
first <- lowerChar <|> char '_'
|
||||
first <- letterChar <|> char '_'
|
||||
rest <- many $ letterChar
|
||||
<|> digitChar <|> char '_' <|> char '-' <|> char '?'
|
||||
<|> char '$' <|> char '@' <|> char '%'
|
||||
<|> char '$' <|> char '%'
|
||||
<|> char '\''
|
||||
let name = first : rest
|
||||
if name == "t" || name == "!result"
|
||||
@@ -114,12 +116,7 @@ identifier = do
|
||||
else return (LIdentifier name)
|
||||
|
||||
namespace :: Lexer LToken
|
||||
namespace = do
|
||||
name <- try (string "!Local") <|> do
|
||||
first <- upperChar
|
||||
rest <- many (letterChar <|> digitChar)
|
||||
return (first:rest)
|
||||
return (LNamespace name)
|
||||
namespace = LNamespace <$> string "!Local"
|
||||
|
||||
dot :: Lexer LToken
|
||||
dot = char '.' $> LDot
|
||||
@@ -130,12 +127,27 @@ lImport = do
|
||||
space1
|
||||
LStringLiteral path <- stringLiteral
|
||||
space1
|
||||
LNamespace name <- namespace
|
||||
name <- importAlias
|
||||
return (LImport path name)
|
||||
|
||||
importAlias :: Lexer String
|
||||
importAlias = string "!Local" <|> do
|
||||
first <- letterChar <|> char '_'
|
||||
rest <- many (letterChar <|> digitChar <|> char '_' <|> char '-' <|> char '?' <|> char '$' <|> char '%' <|> char '\'' <|> char '.')
|
||||
let name = first : rest
|
||||
if name == "t" || name == "!result"
|
||||
then fail "Keywords (`t`, `!result`) cannot be used as an import alias"
|
||||
else pure name
|
||||
|
||||
assignAt :: Lexer LToken
|
||||
assignAt = string "=@" $> LAssignAt
|
||||
|
||||
assign :: Lexer LToken
|
||||
assign = char '=' $> LAssign
|
||||
|
||||
atSign :: Lexer LToken
|
||||
atSign = char '@' $> LAt
|
||||
|
||||
colon :: Lexer LToken
|
||||
colon = char ':' $> LColon
|
||||
|
||||
|
||||
353
src/Main.hs
353
src/Main.hs
@@ -1,17 +1,27 @@
|
||||
module Main where
|
||||
|
||||
import ContentStore (initContentStoreWithPath, loadEnvironment, loadTerm, loadTree, resolveExportTarget)
|
||||
import Check (checkFile, checkFileWithStore, instrumentIOContinuations)
|
||||
import ContentStore
|
||||
import ContentStore.Bundle
|
||||
import Module.Manifest
|
||||
import System.Exit (die)
|
||||
import Eval (evalTricu, evalTricuWithStore, mainResult, result)
|
||||
import FileEval (evaluateFileWithContext, evaluateFileWithStore, compileFile)
|
||||
import Eval (evalTricu, mainResult, result)
|
||||
import FileEval
|
||||
( ContractMode(..)
|
||||
, LoadedSource(..)
|
||||
, defaultStorePath
|
||||
, evaluateFileWithContextWithStoreAndMode
|
||||
, evaluateFileWithStore
|
||||
, loadFileWithStoreMode
|
||||
, compileFileWithStore
|
||||
)
|
||||
import IODriver (IOPermissions(..), runIO)
|
||||
import Parser (parseTricu)
|
||||
import REPL (repl)
|
||||
import Research (T, EvaluatedForm(..), Env, formatT, exportDag)
|
||||
import Wire (buildBundle, encodeBundle, importBundle, defaultExportNames, Bundle(..))
|
||||
import Wire (encodeBundle, defaultExportNames, Bundle(..))
|
||||
|
||||
import Control.Monad (foldM, unless, when)
|
||||
import Data.Text (unpack, pack)
|
||||
import qualified Data.Text as T
|
||||
import Data.Version (showVersion)
|
||||
import Paths_tricu (version)
|
||||
@@ -20,10 +30,9 @@ import Options.Applicative
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Sequence as Seq
|
||||
import Database.SQLite.Simple (Connection, close)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import System.Environment (lookupEnv)
|
||||
import System.Directory (getHomeDirectory)
|
||||
import System.FilePath (takeBaseName, (</>))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- CLI argument types
|
||||
@@ -31,11 +40,16 @@ import System.Environment (lookupEnv)
|
||||
|
||||
data TricuArgs
|
||||
= Repl
|
||||
| Check
|
||||
{ checkInput :: FilePath
|
||||
, checkStore :: Maybe FilePath
|
||||
}
|
||||
| Eval
|
||||
{ evalFiles :: [FilePath]
|
||||
, evalStore :: Maybe FilePath
|
||||
, evalFormat :: EvaluatedForm
|
||||
, evalOutput :: FilePath
|
||||
, evalDb :: Maybe FilePath
|
||||
, evalUnchecked :: Bool
|
||||
, evalIo :: Bool
|
||||
, evalAllowRead :: [FilePath]
|
||||
, evalAllowWrite :: [FilePath]
|
||||
@@ -45,21 +59,32 @@ data TricuArgs
|
||||
}
|
||||
| ArboricxCompile
|
||||
{ compileInput :: FilePath
|
||||
, compileStore :: Maybe FilePath
|
||||
, compileOutput :: FilePath
|
||||
, compileNames :: [String]
|
||||
, compileDb :: Maybe FilePath
|
||||
}
|
||||
| ArboricxImport
|
||||
{ importFile :: FilePath
|
||||
, importDb :: Maybe FilePath
|
||||
{ importFile :: FilePath
|
||||
, importStore :: Maybe FilePath
|
||||
, importModule :: Maybe String
|
||||
}
|
||||
| ArboricxExport
|
||||
{ exportTargets :: [String]
|
||||
, exportModules :: [String]
|
||||
, exportOutput :: FilePath
|
||||
, exportNames :: [String]
|
||||
, exportDb :: Maybe FilePath
|
||||
, exportStore :: Maybe FilePath
|
||||
, dag :: Bool
|
||||
}
|
||||
| StoreAliasList
|
||||
{ storeAliasKind :: AliasKind
|
||||
, storePathOpt :: Maybe FilePath
|
||||
}
|
||||
| StoreAliasGet
|
||||
{ storeAliasKind :: AliasKind
|
||||
, storeAliasName :: String
|
||||
, storePathOpt :: Maybe FilePath
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
@@ -78,9 +103,25 @@ readEvaluatedForm = eitherReader $ \s -> case s of
|
||||
"string" -> Right StringLit
|
||||
_ -> Left $ "Unknown format: " ++ s ++ ". Expected: tree, fsl, ast, ternary, ascii, decode, number, string"
|
||||
|
||||
checkParser :: Parser TricuArgs
|
||||
checkParser = Check
|
||||
<$> argument str (metavar "FILE")
|
||||
<*> optional (option str
|
||||
( long "store"
|
||||
<> short 's'
|
||||
<> metavar "PATH"
|
||||
<> help "Content-addressed store path for module import resolution"
|
||||
))
|
||||
|
||||
evalParser :: Parser TricuArgs
|
||||
evalParser = Eval
|
||||
<$> many (argument str (metavar "FILE..."))
|
||||
<*> optional (option str
|
||||
( long "store"
|
||||
<> short 's'
|
||||
<> metavar "PATH"
|
||||
<> help "Content-addressed store path for module import resolution"
|
||||
))
|
||||
<*> option readEvaluatedForm
|
||||
( long "format"
|
||||
<> short 'f'
|
||||
@@ -95,12 +136,10 @@ evalParser = Eval
|
||||
<> value ""
|
||||
<> help "Write output to file instead of stdout"
|
||||
)
|
||||
<*> optional (option str
|
||||
( long "db"
|
||||
<> short 'd'
|
||||
<> metavar "PATH"
|
||||
<> help "Content store database path"
|
||||
))
|
||||
<*> switch
|
||||
( long "unchecked"
|
||||
<> help "Evaluate as untyped code: ignore View Contract annotations and do not publish unchecked view refs"
|
||||
)
|
||||
<*> switch
|
||||
( long "io"
|
||||
<> help "Interpret the result as an IO action tree and execute it"
|
||||
@@ -137,6 +176,12 @@ compileParser = ArboricxCompile
|
||||
<> value ""
|
||||
<> help "Input .tri source file"
|
||||
)
|
||||
<*> optional (option str
|
||||
( long "store"
|
||||
<> short 's'
|
||||
<> metavar "PATH"
|
||||
<> help "Content-addressed store path for module import resolution"
|
||||
))
|
||||
<*> option str
|
||||
( long "output"
|
||||
<> short 'o'
|
||||
@@ -150,12 +195,6 @@ compileParser = ArboricxCompile
|
||||
<> metavar "NAME"
|
||||
<> help "Definition name(s) to export as bundle roots (repeatable)"
|
||||
))
|
||||
<*> optional (option str
|
||||
( long "db"
|
||||
<> short 'd'
|
||||
<> metavar "PATH"
|
||||
<> help "Content store database path"
|
||||
))
|
||||
|
||||
importParser :: Parser TricuArgs
|
||||
importParser = ArboricxImport
|
||||
@@ -167,10 +206,16 @@ importParser = ArboricxImport
|
||||
<> help "Bundle file to import"
|
||||
)
|
||||
<*> optional (option str
|
||||
( long "db"
|
||||
<> short 'd'
|
||||
( long "store"
|
||||
<> short 's'
|
||||
<> metavar "PATH"
|
||||
<> help "Content store database path"
|
||||
<> help "Content-addressed store path"
|
||||
))
|
||||
<*> optional (option str
|
||||
( long "module"
|
||||
<> short 'm'
|
||||
<> metavar "NAME"
|
||||
<> help "Module alias to create for the imported bundle (defaults to bundle file basename)"
|
||||
))
|
||||
|
||||
exportParser :: Parser TricuArgs
|
||||
@@ -181,6 +226,12 @@ exportParser = ArboricxExport
|
||||
<> metavar "TARGET"
|
||||
<> help "Target hash or name (repeatable)"
|
||||
))
|
||||
<*> many (option str
|
||||
( long "module"
|
||||
<> short 'm'
|
||||
<> metavar "MODULE"
|
||||
<> help "Module alias or manifest hash to export (repeatable; bundle export only)"
|
||||
))
|
||||
<*> option str
|
||||
( long "output"
|
||||
<> short 'o'
|
||||
@@ -195,16 +246,54 @@ exportParser = ArboricxExport
|
||||
<> help "Export name(s) for the bundle manifest (repeatable)"
|
||||
))
|
||||
<*> optional (option str
|
||||
( long "db"
|
||||
<> short 'd'
|
||||
( long "store"
|
||||
<> short 's'
|
||||
<> metavar "PATH"
|
||||
<> help "Content store database path"
|
||||
<> help "Content-addressed store path"
|
||||
))
|
||||
<*> switch
|
||||
( long "dag"
|
||||
<> help "Export as a topologically-sorted DAG node table instead of a bundle"
|
||||
)
|
||||
|
||||
aliasKindReader :: ReadM AliasKind
|
||||
aliasKindReader = eitherReader $ \s -> case s of
|
||||
"names" -> Right NameAlias
|
||||
"name" -> Right NameAlias
|
||||
"modules" -> Right ModuleAlias
|
||||
"module" -> Right ModuleAlias
|
||||
"packages" -> Right PackageAlias
|
||||
"package" -> Right PackageAlias
|
||||
_ -> Left "alias kind must be one of: names, modules, packages"
|
||||
|
||||
storePathParser :: Parser (Maybe FilePath)
|
||||
storePathParser = optional (option str
|
||||
( long "store"
|
||||
<> short 's'
|
||||
<> metavar "PATH"
|
||||
<> help "Content-addressed store path"
|
||||
))
|
||||
|
||||
aliasKindParser :: Parser AliasKind
|
||||
aliasKindParser = option aliasKindReader
|
||||
( long "kind"
|
||||
<> short 'k'
|
||||
<> metavar "KIND"
|
||||
<> value NameAlias
|
||||
<> help "Alias kind: names, modules, packages (default: names)"
|
||||
)
|
||||
|
||||
storeAliasListParser :: Parser TricuArgs
|
||||
storeAliasListParser = StoreAliasList
|
||||
<$> aliasKindParser
|
||||
<*> storePathParser
|
||||
|
||||
storeAliasGetParser :: Parser TricuArgs
|
||||
storeAliasGetParser = StoreAliasGet
|
||||
<$> aliasKindParser
|
||||
<*> argument str (metavar "NAME")
|
||||
<*> storePathParser
|
||||
|
||||
versionStr :: String
|
||||
versionStr = "tricu " ++ showVersion version
|
||||
|
||||
@@ -213,10 +302,14 @@ tricuParser = (subparser topCommands <|> pure Repl)
|
||||
<**> infoOption versionStr (long "version" <> help "Show version")
|
||||
where
|
||||
topCommands = mconcat
|
||||
[ command "eval" (info (evalParser <**> helper)
|
||||
[ command "check" (info (checkParser <**> helper)
|
||||
(progDesc "Check View Contract annotations and report ok or diagnostics"))
|
||||
, command "eval" (info (evalParser <**> helper)
|
||||
(progDesc "Evaluate tricu source and print the result of the final expression"))
|
||||
, command "arboricx" (info (arboricxParser <**> helper)
|
||||
(progDesc "Arboricx bundle operations"))
|
||||
, command "store" (info (storeParser <**> helper)
|
||||
(progDesc "Inspect and manage the content-addressed store"))
|
||||
]
|
||||
|
||||
arboricxParser :: Parser TricuArgs
|
||||
@@ -229,6 +322,20 @@ arboricxParser = subparser $ mconcat
|
||||
(progDesc "Export one or more terms from the content store"))
|
||||
]
|
||||
|
||||
storeParser :: Parser TricuArgs
|
||||
storeParser = subparser $ mconcat
|
||||
[ command "alias" (info (storeAliasParser <**> helper)
|
||||
(progDesc "Inspect workspace aliases"))
|
||||
]
|
||||
|
||||
storeAliasParser :: Parser TricuArgs
|
||||
storeAliasParser = subparser $ mconcat
|
||||
[ command "list" (info (storeAliasListParser <**> helper)
|
||||
(progDesc "List aliases by kind"))
|
||||
, command "get" (info (storeAliasGetParser <**> helper)
|
||||
(progDesc "Resolve an alias by kind and name"))
|
||||
]
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Entry point
|
||||
-- ---------------------------------------------------------------------------
|
||||
@@ -242,10 +349,13 @@ main = do
|
||||
)
|
||||
case args of
|
||||
Repl -> runRepl
|
||||
Check {} -> runCheck args
|
||||
Eval {} -> runEval args
|
||||
ArboricxCompile {} -> runCompile args
|
||||
ArboricxImport {} -> runImport args
|
||||
ArboricxExport {} -> runExport args
|
||||
StoreAliasList {} -> runStoreAliasList args
|
||||
StoreAliasGet {} -> runStoreAliasGet args
|
||||
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
@@ -258,25 +368,40 @@ runRepl = do
|
||||
putStrLn "You may exit with `CTRL+D` or the `!exit` command."
|
||||
repl
|
||||
|
||||
runCheck :: TricuArgs -> IO ()
|
||||
runCheck opts = do
|
||||
output <- case checkStore opts of
|
||||
Nothing -> checkFile (checkInput opts)
|
||||
Just storePath -> checkFileWithStore (StorePath storePath) (checkInput opts)
|
||||
putStrLn output
|
||||
|
||||
evaluateCheckedIOFile :: StorePath -> ContractMode -> Env -> FilePath -> IO Env
|
||||
evaluateCheckedIOFile store mode env filePath = do
|
||||
loaded <- loadFileWithStoreMode mode store filePath
|
||||
checkedAst <- case instrumentIOContinuations (loadedAst loaded) of
|
||||
Left err -> die err
|
||||
Right asts -> pure asts
|
||||
viewEnv <- evaluateFileWithStore (Just store) "./lib/view.tri"
|
||||
pure $ evalTricu (Map.unions [viewEnv, loadedImports loaded, env]) checkedAst
|
||||
|
||||
runEval :: TricuArgs -> IO ()
|
||||
runEval opts = do
|
||||
let files = evalFiles opts
|
||||
form = evalFormat opts
|
||||
out = evalOutput opts
|
||||
mconn <- case evalDb opts of
|
||||
Just dbPath -> Just <$> initContentStoreWithPath (Just dbPath)
|
||||
Nothing -> do
|
||||
mDbPath <- lookupEnv "TRICU_DB_PATH"
|
||||
case mDbPath of
|
||||
Just _ -> Just <$> initContentStoreWithPath Nothing
|
||||
Nothing -> return Nothing
|
||||
resultT <- case files of
|
||||
[] -> do
|
||||
input <- getContents
|
||||
env <- evalTricuWithStore mconn Map.empty (parseTricu input)
|
||||
let env = evalTricu Map.empty (parseTricu input)
|
||||
return $ result env
|
||||
_ -> do
|
||||
finalEnv <- foldM (evaluateFileWithStore mconn) Map.empty files
|
||||
mStoreOpt <- traverse (pure . StorePath) (evalStore opts)
|
||||
let contractMode = if evalUnchecked opts then IgnoreContracts else EnforceContracts
|
||||
finalEnv <- if evalIo opts && contractMode == EnforceContracts
|
||||
then do
|
||||
store <- maybe defaultStorePath pure mStoreOpt
|
||||
foldM (evaluateCheckedIOFile store contractMode) Map.empty files
|
||||
else foldM (evaluateFileWithContextWithStoreAndMode contractMode mStoreOpt) Map.empty files
|
||||
return $ mainResult finalEnv
|
||||
finalT <- if evalIo opts
|
||||
then do
|
||||
@@ -291,9 +416,6 @@ runEval opts = do
|
||||
Left err -> die $ "IO error: " ++ err
|
||||
Right val -> pure val
|
||||
else return resultT
|
||||
case mconn of
|
||||
Just conn -> close conn
|
||||
Nothing -> return ()
|
||||
writeOutput out (formatT form finalT)
|
||||
|
||||
runCompile :: TricuArgs -> IO ()
|
||||
@@ -301,20 +423,35 @@ runCompile opts = do
|
||||
let input = compileInput opts
|
||||
out = compileOutput opts
|
||||
names = compileNames opts
|
||||
mStore = StorePath <$> compileStore opts
|
||||
when (null out) $ die "tricu arboricx compile: --output is required"
|
||||
when (null input) $ die "tricu arboricx compile: input file is required"
|
||||
let nameTexts = if null names then [] else map T.pack names
|
||||
compileFile input out nameTexts
|
||||
compileFileWithStore mStore input out nameTexts
|
||||
|
||||
runImport :: TricuArgs -> IO ()
|
||||
runImport opts = do
|
||||
let file = importFile opts
|
||||
when (null file) $ die "tricu arboricx import: input file is required"
|
||||
withContentStore (importDb opts) $ \conn -> do
|
||||
bundleData <- BL.readFile file
|
||||
roots <- map T.unpack <$> importBundle conn (BL.toStrict bundleData)
|
||||
putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
|
||||
mapM_ (\r -> putStrLn $ " " ++ r) roots
|
||||
store <- resolveStorePath (importStore opts)
|
||||
bundleData <- BL.readFile file
|
||||
roots <- unpackBundleToStore store (BL.toStrict bundleData)
|
||||
mapM_ (\(name, root) ->
|
||||
writeAlias store NameAlias name (treeTermRef root)) roots
|
||||
let manifest = ModuleManifest []
|
||||
[ ModuleExport
|
||||
name
|
||||
(treeTermRef root)
|
||||
"arboricx.abi.tree.v1"
|
||||
Nothing
|
||||
| (name, root) <- roots
|
||||
]
|
||||
moduleName = T.pack $ maybe (takeBaseName file) id (importModule opts)
|
||||
manifestHash <- putManifest store manifest
|
||||
writeAlias store ModuleAlias moduleName (ObjectRef (unDomain manifestDomain) manifestHash)
|
||||
putStrLn $ "Imported " ++ show (length roots) ++ " root(s):"
|
||||
mapM_ (\(name, root) -> putStrLn $ " " ++ T.unpack name ++ " -> " ++ T.unpack root) roots
|
||||
putStrLn $ "Created module alias " ++ T.unpack moduleName ++ " -> " ++ T.unpack manifestHash
|
||||
|
||||
runExport :: TricuArgs -> IO ()
|
||||
runExport opts =
|
||||
@@ -325,37 +462,53 @@ runExport opts =
|
||||
runExportBundle :: TricuArgs -> IO ()
|
||||
runExportBundle opts = do
|
||||
let targets = exportTargets opts
|
||||
modules = exportModules opts
|
||||
out = exportOutput opts
|
||||
names = exportNames opts
|
||||
when (null out) $ die "tricu arboricx export: --output is required"
|
||||
when (null targets) $ die "tricu arboricx export: at least one --target is required"
|
||||
withContentStore (exportDb opts) $ \conn -> do
|
||||
terms <- mapM (\t -> do
|
||||
(h, _) <- resolveExportTarget conn t
|
||||
maybeTree <- loadTree conn h
|
||||
case maybeTree of
|
||||
Nothing -> die $ "Term not found in store: " ++ t
|
||||
Just tree -> return tree) targets
|
||||
let expNames = if null names
|
||||
then defaultExportNames (length terms)
|
||||
else map T.pack names
|
||||
when (length expNames /= length terms) $
|
||||
die "tricu arboricx export: number of --name values must match number of TARGETs"
|
||||
let namedTerms = zip expNames terms
|
||||
bundle = buildBundle namedTerms
|
||||
bundleData = encodeBundle bundle
|
||||
BL.writeFile out (BL.fromStrict bundleData)
|
||||
putStrLn $ "Exported bundle with " ++ show (length namedTerms) ++ " export(s) to " ++ out
|
||||
putStrLn $ " nodes: " ++ show (Seq.length (bundleNodes bundle))
|
||||
putStrLn $ " size: " ++ show (BS.length bundleData) ++ " bytes"
|
||||
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"
|
||||
store <- resolveStorePath (exportStore opts)
|
||||
targetRoots <- mapM (resolveStoreTarget store) targets
|
||||
moduleRoots <- concat <$> mapM (resolveModuleExports store) modules
|
||||
let targetEntries = zip (defaultExportNames (length targetRoots)) targetRoots
|
||||
entries = targetEntries ++ moduleRoots
|
||||
expNames = if null names then map fst entries else map T.pack names
|
||||
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"
|
||||
|
||||
runStoreAliasList :: TricuArgs -> IO ()
|
||||
runStoreAliasList opts = do
|
||||
store <- resolveStorePath (storePathOpt opts)
|
||||
aliases <- listAliases store (storeAliasKind opts)
|
||||
mapM_ (\(name, ref) -> putStrLn $ T.unpack name ++ " -> " ++ formatObjectRef ref) aliases
|
||||
|
||||
runStoreAliasGet :: TricuArgs -> IO ()
|
||||
runStoreAliasGet opts = do
|
||||
store <- resolveStorePath (storePathOpt opts)
|
||||
mRef <- readAlias store (storeAliasKind opts) (T.pack $ storeAliasName opts)
|
||||
case mRef of
|
||||
Nothing -> die $ "alias not found: " ++ storeAliasName opts
|
||||
Just ref -> putStrLn $ storeAliasName opts ++ " -> " ++ formatObjectRef ref
|
||||
|
||||
runExportDag :: TricuArgs -> IO ()
|
||||
runExportDag opts = do
|
||||
let targets = exportTargets opts
|
||||
modules = exportModules opts
|
||||
out = exportOutput opts
|
||||
unless (null modules) $
|
||||
die "tricu arboricx export --dag: --module is only supported for bundle export"
|
||||
case targets of
|
||||
[target] -> withContentStore (exportDb opts) $ \conn -> do
|
||||
maybeTerm <- loadTerm conn target
|
||||
[target] -> do
|
||||
store <- resolveStorePath (exportStore opts)
|
||||
root <- resolveStoreTarget store target
|
||||
maybeTerm <- getTreeTerm store root
|
||||
case maybeTerm of
|
||||
Nothing -> die $ "Term not found: " ++ target
|
||||
Just term -> do
|
||||
@@ -371,12 +524,54 @@ runExportDag opts = do
|
||||
-- Helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
withContentStore :: Maybe FilePath -> (Connection -> IO a) -> IO a
|
||||
withContentStore mPath act = do
|
||||
conn <- initContentStoreWithPath mPath
|
||||
result <- act conn
|
||||
close conn
|
||||
return result
|
||||
resolveStorePath :: Maybe FilePath -> IO StorePath
|
||||
resolveStorePath (Just path) = return (StorePath path)
|
||||
resolveStorePath Nothing = do
|
||||
home <- getHomeDirectory
|
||||
return (StorePath (home </> ".tricu" </> "store"))
|
||||
|
||||
treeTermRef :: ObjectHash -> ObjectRef
|
||||
treeTermRef = ObjectRef (unDomain treeTermDomain)
|
||||
|
||||
resolveStoreTarget :: StorePath -> String -> IO ObjectHash
|
||||
resolveStoreTarget store target = do
|
||||
mAlias <- readAlias store NameAlias (T.pack target)
|
||||
let root = maybe (T.pack target) objectRefHash mAlias
|
||||
mTree <- getTreeTerm store root
|
||||
case mTree of
|
||||
Just _ -> return root
|
||||
Nothing -> die $ "Term not found in store: " ++ target
|
||||
|
||||
resolveModuleExports :: StorePath -> String -> IO [(T.Text, ObjectHash)]
|
||||
resolveModuleExports store moduleTarget = do
|
||||
manifestHash <- resolveModuleManifestHash store moduleTarget
|
||||
mManifest <- getManifest store manifestHash
|
||||
manifest <- case mManifest of
|
||||
Nothing -> die $ "Module manifest not found in store: " ++ moduleTarget
|
||||
Just value -> return value
|
||||
mapM exportEntry (moduleManifestExports manifest)
|
||||
where
|
||||
exportEntry ex = do
|
||||
let ref = moduleExportObject ex
|
||||
unless (objectRefKind ref == unDomain treeTermDomain) $
|
||||
die $ "Unsupported module export object kind for " ++ T.unpack (moduleExportName ex) ++ ": " ++ T.unpack (objectRefKind ref)
|
||||
mTree <- getTreeTerm store (objectRefHash ref)
|
||||
case mTree of
|
||||
Nothing -> die $ "Module export tree term not found: " ++ T.unpack (moduleExportName ex)
|
||||
Just _ -> return (moduleExportName ex, objectRefHash ref)
|
||||
|
||||
resolveModuleManifestHash :: StorePath -> String -> IO ObjectHash
|
||||
resolveModuleManifestHash store moduleTarget = do
|
||||
mAlias <- readAlias store ModuleAlias (T.pack moduleTarget)
|
||||
case mAlias of
|
||||
Just ref -> do
|
||||
unless (objectRefKind ref == unDomain manifestDomain) $
|
||||
die $ "Module alias does not point at a module manifest: " ++ moduleTarget
|
||||
return (objectRefHash ref)
|
||||
Nothing -> return (T.pack moduleTarget)
|
||||
|
||||
formatObjectRef :: ObjectRef -> String
|
||||
formatObjectRef ref = T.unpack (objectRefKind ref) ++ " " ++ T.unpack (objectRefHash ref)
|
||||
|
||||
writeOutput :: FilePath -> String -> IO ()
|
||||
writeOutput path content
|
||||
|
||||
137
src/Module/Manifest.hs
Normal file
137
src/Module/Manifest.hs
Normal file
@@ -0,0 +1,137 @@
|
||||
module Module.Manifest
|
||||
( ModuleManifest(..)
|
||||
, ModuleReference(..)
|
||||
, ModuleExport(..)
|
||||
, manifestDomain
|
||||
, encodeManifest
|
||||
, decodeManifest
|
||||
, putManifest
|
||||
, getManifest
|
||||
) where
|
||||
|
||||
import ContentStore.Filesystem (getObject, putObject)
|
||||
import ContentStore.Object
|
||||
import ContentStore.Alias (ObjectRef(..))
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
-- | Immutable module artifact. Names are export labels inside this manifest;
|
||||
-- content identity is carried by object references and the manifest CAS hash.
|
||||
data ModuleManifest = ModuleManifest
|
||||
{ moduleManifestReferences :: [ModuleReference]
|
||||
, moduleManifestExports :: [ModuleExport]
|
||||
} deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Direct content-addressed reference needed to understand, fetch, or audit
|
||||
-- this manifest. The alias is human-facing metadata for diagnostics/workspace
|
||||
-- presentation; the referenced object is the portable identity. These are not
|
||||
-- source-language imports.
|
||||
data ModuleReference = ModuleReference
|
||||
{ moduleReferenceAlias :: Text
|
||||
, moduleReferenceRef :: ObjectRef
|
||||
} deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Exported executable artifact plus optional direct View Contract type.
|
||||
data ModuleExport = ModuleExport
|
||||
{ moduleExportName :: Text
|
||||
, moduleExportObject :: ObjectRef
|
||||
, moduleExportAbi :: Text
|
||||
, moduleExportView :: Maybe ObjectRef
|
||||
} deriving (Eq, Ord, Show)
|
||||
|
||||
manifestDomain :: Domain
|
||||
manifestDomain = Domain "arboricx.module-manifest.v1"
|
||||
|
||||
encodeManifest :: ModuleManifest -> ByteString
|
||||
encodeManifest manifest = encodeUtf8 $ Text.unlines $
|
||||
["arboricx.module-manifest.v1"]
|
||||
++ map encodeReference (moduleManifestReferences manifest)
|
||||
++ map encodeExport (moduleManifestExports manifest)
|
||||
where
|
||||
encodeReference ref = Text.intercalate "\t"
|
||||
[ "reference"
|
||||
, esc (moduleReferenceAlias ref)
|
||||
, esc (objectRefKind $ moduleReferenceRef ref)
|
||||
, esc (objectRefHash $ moduleReferenceRef ref)
|
||||
]
|
||||
encodeExport ex = Text.intercalate "\t"
|
||||
[ "export"
|
||||
, esc (moduleExportName ex)
|
||||
, esc (objectRefKind $ moduleExportObject ex)
|
||||
, esc (objectRefHash $ moduleExportObject ex)
|
||||
, esc (moduleExportAbi ex)
|
||||
, maybe "-" (esc . objectRefKind) (moduleExportView ex)
|
||||
, maybe "-" (esc . objectRefHash) (moduleExportView ex)
|
||||
]
|
||||
|
||||
-- | Parse the canonical manifest encoding.
|
||||
decodeManifest :: ByteString -> Either String ModuleManifest
|
||||
decodeManifest bs = do
|
||||
txt <- either (Left . show) Right (decodeUtf8' bs)
|
||||
case Text.lines txt of
|
||||
[] -> Left "empty module manifest"
|
||||
header : rows
|
||||
| header /= "arboricx.module-manifest.v1" -> Left "unsupported module manifest version"
|
||||
| otherwise -> foldl step (Right (ModuleManifest [] [])) rows
|
||||
where
|
||||
step acc line = do
|
||||
manifest <- acc
|
||||
case Text.splitOn "\t" line of
|
||||
["reference", alias, kind, hash] -> do
|
||||
ref <- ModuleReference <$> unesc alias <*> (ObjectRef <$> unesc kind <*> unesc hash)
|
||||
Right manifest { moduleManifestReferences = moduleManifestReferences manifest ++ [ref] }
|
||||
["export", name, kind, hash, abi, viewKind, viewHash] -> do
|
||||
view <- optionalRef viewKind viewHash
|
||||
ex <- ModuleExport
|
||||
<$> unesc name
|
||||
<*> (ObjectRef <$> unesc kind <*> unesc hash)
|
||||
<*> unesc abi
|
||||
<*> pure view
|
||||
Right manifest { moduleManifestExports = moduleManifestExports manifest ++ [ex] }
|
||||
_ -> Left $ "invalid module manifest row: " ++ Text.unpack line
|
||||
|
||||
putManifest :: StorePath -> ModuleManifest -> IO ObjectHash
|
||||
putManifest store = putObject store manifestDomain . encodeManifest
|
||||
|
||||
getManifest :: StorePath -> ObjectHash -> IO (Maybe ModuleManifest)
|
||||
getManifest store h = do
|
||||
mBytes <- getObject store h
|
||||
case mBytes of
|
||||
Nothing -> return Nothing
|
||||
Just bytes -> case decodeManifest bytes of
|
||||
Left err -> fail $ "invalid module manifest " ++ Text.unpack h ++ ": " ++ err
|
||||
Right manifest -> return (Just manifest)
|
||||
|
||||
optionalRef :: Text -> Text -> Either String (Maybe ObjectRef)
|
||||
optionalRef "-" "-" = Right Nothing
|
||||
optionalRef kind hash = Just <$> (ObjectRef <$> unesc kind <*> unesc hash)
|
||||
|
||||
esc :: Text -> Text
|
||||
esc = Text.concatMap $ \c -> case c of
|
||||
'%' -> "%25"
|
||||
'\t' -> "%09"
|
||||
'\n' -> "%0A"
|
||||
'\r' -> "%0D"
|
||||
_ -> Text.singleton c
|
||||
|
||||
unesc :: Text -> Either String Text
|
||||
unesc txt = go txt ""
|
||||
where
|
||||
go rest acc = case Text.uncons rest of
|
||||
Nothing -> Right acc
|
||||
Just ('%', xs) ->
|
||||
let (code, tail') = Text.splitAt 2 xs
|
||||
decoded = case code of
|
||||
"25" -> Just "%"
|
||||
"09" -> Just "\t"
|
||||
"0A" -> Just "\n"
|
||||
"0D" -> Just "\r"
|
||||
_ -> Nothing
|
||||
in case decoded of
|
||||
Nothing -> Left $ "invalid percent escape: %" ++ Text.unpack code
|
||||
Just c -> go tail' (acc <> c)
|
||||
Just (c, xs) -> go xs (acc <> Text.singleton c)
|
||||
153
src/Module/Resolver.hs
Normal file
153
src/Module/Resolver.hs
Normal file
@@ -0,0 +1,153 @@
|
||||
module Module.Resolver
|
||||
( ResolvedExport(..)
|
||||
, ResolvedModule(..)
|
||||
, resolveModuleImport
|
||||
, resolveModuleImportSelecting
|
||||
, resolveModuleImports
|
||||
, resolvedModulesEnv
|
||||
) where
|
||||
|
||||
import ContentStore.Alias
|
||||
import ContentStore.Arboricx (decodeTreeTerm, treeTermDomain)
|
||||
import ContentStore.ViewTree (decodeViewTree, viewTreeKind, viewTreeRootTerm)
|
||||
import ContentStore.Object
|
||||
import ContentStore.Resolver
|
||||
import Module.Manifest
|
||||
import Research
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- | A manifest export resolved into the importing source's local lexical scope.
|
||||
-- The executable term is loaded, while object/view refs remain available for
|
||||
-- later checker and diagnostics phases.
|
||||
data ResolvedExport = ResolvedExport
|
||||
{ resolvedExportSourceName :: T.Text
|
||||
, resolvedExportLocalName :: String
|
||||
, resolvedExportObject :: ObjectRef
|
||||
, resolvedExportAbi :: T.Text
|
||||
, resolvedExportView :: Maybe ObjectRef
|
||||
, resolvedExportTerm :: T
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data ResolvedModule = ResolvedModule
|
||||
{ resolvedModuleTarget :: String
|
||||
, resolvedModuleNamespace :: String
|
||||
, resolvedModuleManifest :: ObjectHash
|
||||
, resolvedModuleExports :: [ResolvedExport]
|
||||
} deriving (Show, Eq)
|
||||
|
||||
resolveModuleImports :: ObjectResolver -> [TricuAST] -> IO ([ResolvedModule], [TricuAST])
|
||||
resolveModuleImports resolver asts = do
|
||||
let (imports, nonImports) = foldr splitImport ([], []) asts
|
||||
modules <- mapM (uncurry (resolveModuleImport resolver)) imports
|
||||
return (modules, nonImports)
|
||||
where
|
||||
splitImport (SImport target namespace) (is, rest) = ((target, namespace) : is, rest)
|
||||
splitImport ast (is, rest) = (is, ast : rest)
|
||||
|
||||
resolveModuleImport :: ObjectResolver -> String -> String -> IO ResolvedModule
|
||||
resolveModuleImport resolver moduleTarget namespace =
|
||||
resolveModuleImportSelecting resolver Nothing moduleTarget namespace
|
||||
|
||||
resolveModuleImportSelecting :: ObjectResolver -> Maybe (Set.Set T.Text) -> String -> String -> IO ResolvedModule
|
||||
resolveModuleImportSelecting resolver selected moduleTarget namespace = do
|
||||
manifestHash <- resolveModuleManifestHash resolver moduleTarget
|
||||
mManifest <- resolveManifest resolver manifestHash
|
||||
manifest <- case mManifest of
|
||||
Nothing -> errorWithoutStackTrace $
|
||||
"Module import failed for " ++ show moduleTarget
|
||||
++ " as " ++ show namespace
|
||||
++ ": manifest object not found (kind " ++ T.unpack (unDomain manifestDomain)
|
||||
++ ", hash " ++ T.unpack manifestHash ++ ")"
|
||||
Just value -> return value
|
||||
let wantedExports = case selected of
|
||||
Nothing -> moduleManifestExports manifest
|
||||
Just names -> filter (\ex -> moduleExportName ex `Set.member` names) (moduleManifestExports manifest)
|
||||
exports <- mapM (resolveModuleExport resolver localNamespace) wantedExports
|
||||
return ResolvedModule
|
||||
{ resolvedModuleTarget = moduleTarget
|
||||
, resolvedModuleNamespace = namespace
|
||||
, resolvedModuleManifest = manifestHash
|
||||
, resolvedModuleExports = exports
|
||||
}
|
||||
where
|
||||
localNamespace = if namespace == "!Local" then "" else namespace
|
||||
|
||||
resolveModuleExport :: ObjectResolver -> String -> ModuleExport -> IO ResolvedExport
|
||||
resolveModuleExport resolver namespace ex = do
|
||||
let ref = moduleExportObject ex
|
||||
sourceName = moduleExportName ex
|
||||
term <- resolveExportTerm resolver sourceName ref
|
||||
return ResolvedExport
|
||||
{ resolvedExportSourceName = sourceName
|
||||
, resolvedExportLocalName = nsVariable namespace (T.unpack sourceName)
|
||||
, resolvedExportObject = ref
|
||||
, resolvedExportAbi = moduleExportAbi ex
|
||||
, resolvedExportView = moduleExportView ex
|
||||
, resolvedExportTerm = term
|
||||
}
|
||||
|
||||
resolveExportTerm :: ObjectResolver -> T.Text -> ObjectRef -> IO T
|
||||
resolveExportTerm resolver sourceName ref
|
||||
| objectRefKind ref == viewTreeKind = do
|
||||
bytes <- requireObject "view tree"
|
||||
case decodeViewTree bytes >>= viewTreeRootTerm of
|
||||
Left err -> errorWithoutStackTrace $
|
||||
"Module export " ++ show (T.unpack sourceName)
|
||||
++ " references invalid view tree " ++ T.unpack (objectRefHash ref)
|
||||
++ ": " ++ err
|
||||
Right term -> return term
|
||||
| objectRefKind ref == unDomain treeTermDomain = do
|
||||
bytes <- requireObject "tree term"
|
||||
case decodeTreeTerm bytes of
|
||||
Left err -> errorWithoutStackTrace $
|
||||
"Module export " ++ show (T.unpack sourceName)
|
||||
++ " references invalid tree term " ++ T.unpack (objectRefHash ref)
|
||||
++ ": " ++ err
|
||||
Right term -> return term
|
||||
| otherwise = errorWithoutStackTrace $
|
||||
"Module export " ++ show (T.unpack sourceName)
|
||||
++ " has unsupported object kind " ++ show (T.unpack (objectRefKind ref))
|
||||
++ "; expected " ++ show (T.unpack viewTreeKind)
|
||||
++ " or " ++ show (T.unpack (unDomain treeTermDomain))
|
||||
where
|
||||
requireObject label = do
|
||||
mBytes <- resolverObject resolver ref
|
||||
case mBytes of
|
||||
Just bytes -> return bytes
|
||||
Nothing -> errorWithoutStackTrace $
|
||||
"Module export " ++ show (T.unpack sourceName)
|
||||
++ " references missing " ++ label ++ " " ++ T.unpack (objectRefHash ref)
|
||||
++ " (kind " ++ T.unpack (objectRefKind ref) ++ ")"
|
||||
|
||||
resolvedModulesEnv :: [ResolvedModule] -> Env
|
||||
resolvedModulesEnv modules = Map.fromList
|
||||
[ (resolvedExportLocalName ex, resolvedExportTerm ex)
|
||||
| m <- modules
|
||||
, ex <- resolvedModuleExports m
|
||||
]
|
||||
|
||||
resolveModuleManifestHash :: ObjectResolver -> String -> IO ObjectHash
|
||||
resolveModuleManifestHash resolver moduleTarget = do
|
||||
mAlias <- resolverAlias resolver ModuleAlias (T.pack moduleTarget)
|
||||
case mAlias of
|
||||
Just ref ->
|
||||
if objectRefKind ref == unDomain manifestDomain
|
||||
then return (objectRefHash ref)
|
||||
else errorWithoutStackTrace $
|
||||
"Module alias " ++ show moduleTarget
|
||||
++ " points at unsupported object kind " ++ show (T.unpack (objectRefKind ref))
|
||||
++ "; expected " ++ show (T.unpack (unDomain manifestDomain))
|
||||
++ " (hash " ++ T.unpack (objectRefHash ref) ++ ")"
|
||||
Nothing ->
|
||||
case textToHashBytes (T.pack moduleTarget) of
|
||||
Right _ -> return (T.pack moduleTarget)
|
||||
Left _ -> errorWithoutStackTrace $
|
||||
"Module alias not found: " ++ show moduleTarget
|
||||
++ "; add it to tricu.workspace or write a ModuleAlias, or import by manifest hash"
|
||||
|
||||
nsVariable :: String -> String -> String
|
||||
nsVariable "" name = name
|
||||
nsVariable moduleName name = moduleName ++ "." ++ name
|
||||
66
src/Module/Workspace.hs
Normal file
66
src/Module/Workspace.hs
Normal file
@@ -0,0 +1,66 @@
|
||||
module Module.Workspace
|
||||
( Workspace(..)
|
||||
, emptyWorkspace
|
||||
, lookupWorkspaceModule
|
||||
, findWorkspaceFor
|
||||
, parseWorkspace
|
||||
) where
|
||||
|
||||
import Data.Char (isSpace)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import System.Directory (doesDirectoryExist, doesFileExist)
|
||||
import System.FilePath (takeDirectory, (</>))
|
||||
|
||||
data Workspace = Workspace
|
||||
{ workspaceRoot :: FilePath
|
||||
, workspaceModules :: Map.Map T.Text FilePath
|
||||
} deriving (Show, Eq)
|
||||
|
||||
emptyWorkspace :: Workspace
|
||||
emptyWorkspace = Workspace "" Map.empty
|
||||
|
||||
lookupWorkspaceModule :: Workspace -> T.Text -> Maybe FilePath
|
||||
lookupWorkspaceModule (Workspace root modules) name = (root </>) <$> Map.lookup name modules
|
||||
|
||||
findWorkspaceFor :: FilePath -> IO Workspace
|
||||
findWorkspaceFor sourcePath = search (takeDirectory sourcePath)
|
||||
where
|
||||
search dir = do
|
||||
let path = dir </> "tricu.workspace"
|
||||
exists <- doesFileExist path
|
||||
if exists
|
||||
then parseWorkspaceAt dir <$> readFile path
|
||||
else do
|
||||
let parent = takeDirectory dir
|
||||
if parent == dir
|
||||
then return emptyWorkspace
|
||||
else do
|
||||
parentExists <- doesDirectoryExist parent
|
||||
if parentExists then search parent else return emptyWorkspace
|
||||
|
||||
parseWorkspace :: String -> Workspace
|
||||
parseWorkspace = parseWorkspaceAt ""
|
||||
|
||||
parseWorkspaceAt :: FilePath -> String -> Workspace
|
||||
parseWorkspaceAt root input = Workspace root $ Map.fromList
|
||||
[ (T.pack name, path)
|
||||
| raw <- lines input
|
||||
, Just (name, path) <- [parseLine raw]
|
||||
]
|
||||
|
||||
parseLine :: String -> Maybe (String, FilePath)
|
||||
parseLine raw =
|
||||
let line = trim (takeWhile (/= '#') raw)
|
||||
in case words line of
|
||||
[] -> Nothing
|
||||
["module", name, "=", path] -> Just (name, stripQuotes path)
|
||||
_ -> Nothing
|
||||
|
||||
trim :: String -> String
|
||||
trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
|
||||
|
||||
stripQuotes :: String -> String
|
||||
stripQuotes s = case s of
|
||||
('"':rest) | not (null rest) && last rest == '"' -> init rest
|
||||
_ -> s
|
||||
154
src/Parser.hs
154
src/Parser.hs
@@ -75,20 +75,133 @@ topItemP = do
|
||||
|
||||
definitionHeadTop :: [LToken] -> Maybe (String, [String])
|
||||
definitionHeadTop toks =
|
||||
case collectIdentifiersNoNewlines toks of
|
||||
(name:args, LAssign : _)
|
||||
case toks of
|
||||
LIdentifier name : rest
|
||||
| name `Set.notMember` reservedNames
|
||||
, all (`Set.notMember` reservedNames) args -> Just (name, args)
|
||||
_ -> Nothing
|
||||
, definitionAssignOnLine rest -> Just (name, [])
|
||||
_ -> Nothing
|
||||
|
||||
-- A top-level definition head is any identifier-led line containing `=` or `=@`.
|
||||
-- Detailed validation happens in definitionP.
|
||||
definitionAssignOnLine :: [LToken] -> Bool
|
||||
definitionAssignOnLine [] = False
|
||||
definitionAssignOnLine (LNewline : _) = False
|
||||
definitionAssignOnLine (LAssign : _) = True
|
||||
definitionAssignOnLine (LAssignAt : _) = True
|
||||
definitionAssignOnLine (LIdentifier "where" : _) = False
|
||||
definitionAssignOnLine (LIdentifier "in" : _) = False
|
||||
definitionAssignOnLine (_ : rest) = definitionAssignOnLine rest
|
||||
|
||||
definitionP :: TokParser TricuAST
|
||||
definitionP = do
|
||||
name <- identifierNameP
|
||||
args <- many identifierNameP
|
||||
void (tok (== LAssign) "=")
|
||||
(args, annotated) <- definitionArgsP False
|
||||
ret <- optional returnAnnotationP
|
||||
bodyIndent <- skipNestedNewlinesGetIndent
|
||||
body <- exprAtIndentP bodyIndent
|
||||
pure (SDef name args body)
|
||||
if annotated || ret /= Nothing
|
||||
then pure (SDefAnn name args ret body)
|
||||
else pure (SDef name (binderNames args) body)
|
||||
|
||||
binderNames :: [DefArg] -> [String]
|
||||
binderNames [] = []
|
||||
binderNames (DefBinder name _ : rest) = name : binderNames rest
|
||||
binderNames (DefPhantom _ : rest) = binderNames rest
|
||||
|
||||
definitionArgsP :: Bool -> TokParser ([DefArg], Bool)
|
||||
definitionArgsP seenPhantom = do
|
||||
mt <- peekP
|
||||
case mt of
|
||||
Just LAssign -> do
|
||||
void (tok (== LAssign) "=")
|
||||
pure ([], False)
|
||||
Just LAssignAt -> pure ([], False)
|
||||
Just (LIdentifier _) | not seenPhantom -> do
|
||||
name <- identifierNameP
|
||||
mAnn <- optional (try (tok (== LAt) "@" *> annotationTypeP))
|
||||
(rest, ann) <- definitionArgsP seenPhantom
|
||||
pure (DefBinder name mAnn : rest, ann || mAnn /= Nothing)
|
||||
Just LAt -> do
|
||||
void (tok (== LAt) "@")
|
||||
ty <- annotationTypeP
|
||||
(rest, ann) <- definitionArgsP True
|
||||
pure (DefPhantom ty : rest, True || ann)
|
||||
Just (LIdentifier _) -> fail "named binders cannot appear after phantom type annotations"
|
||||
_ -> fail "expected definition argument or assignment"
|
||||
|
||||
returnAnnotationP :: TokParser ViewExpr
|
||||
returnAnnotationP = do
|
||||
void (tok (== LAssignAt) "=@")
|
||||
annotationTypeP
|
||||
|
||||
annotationTypeP :: TokParser ViewExpr
|
||||
annotationTypeP =
|
||||
atomicTypeP
|
||||
<|> parenTypeP
|
||||
|
||||
parenTypeP :: TokParser ViewExpr
|
||||
parenTypeP = do
|
||||
void (tok (== LOpenParen) "(")
|
||||
ty <- typeP
|
||||
void (tok (== LCloseParen) ")")
|
||||
pure ty
|
||||
|
||||
typeP :: TokParser ViewExpr
|
||||
typeP = appTypeP
|
||||
|
||||
appTypeP :: TokParser ViewExpr
|
||||
appTypeP = do
|
||||
first <- typeAtomP
|
||||
rest <- many typeAtomP
|
||||
pure (foldl VEApp first rest)
|
||||
|
||||
typeAtomP :: TokParser ViewExpr
|
||||
typeAtomP =
|
||||
typeListP
|
||||
<|> typeStringP
|
||||
<|> typeIntP
|
||||
<|> atomicTypeP
|
||||
<|> parenTypeP
|
||||
|
||||
typeListP :: TokParser ViewExpr
|
||||
typeListP = do
|
||||
void (tok (== LOpenBracket) "[")
|
||||
args <- many typeP
|
||||
void (tok (== LCloseBracket) "]")
|
||||
pure (VEList args)
|
||||
|
||||
typeIntP :: TokParser ViewExpr
|
||||
typeIntP = do
|
||||
n <- tok isInt "integer"
|
||||
case n of
|
||||
LIntegerLiteral i -> pure (VEInt (fromIntegral i))
|
||||
_ -> fail "internal parser error: expected integer"
|
||||
where
|
||||
isInt (LIntegerLiteral _) = True
|
||||
isInt _ = False
|
||||
|
||||
typeStringP :: TokParser ViewExpr
|
||||
typeStringP = do
|
||||
s <- tok isString "string"
|
||||
case s of
|
||||
LStringLiteral value -> pure (VEString value)
|
||||
_ -> fail "internal parser error: expected string"
|
||||
where
|
||||
isString (LStringLiteral _) = True
|
||||
isString _ = False
|
||||
|
||||
atomicTypeP :: TokParser ViewExpr
|
||||
atomicTypeP = do
|
||||
t <- tok isTypeName "type name"
|
||||
case t of
|
||||
LNamespace name -> pure (VEName name)
|
||||
LIdentifier name -> pure (VEName name)
|
||||
_ -> fail "internal parser error: expected type name"
|
||||
|
||||
isTypeName :: LToken -> Bool
|
||||
isTypeName (LNamespace _) = True
|
||||
isTypeName (LIdentifier _) = True
|
||||
isTypeName _ = False
|
||||
|
||||
importP :: TokParser TricuAST
|
||||
importP = do
|
||||
@@ -146,15 +259,17 @@ lambdaHeadNested toks =
|
||||
_ -> Nothing
|
||||
|
||||
collectIdentifiersNoNewlines :: [LToken] -> ([String], [LToken])
|
||||
collectIdentifiersNoNewlines (LIdentifier name : rest) =
|
||||
let (names, final) = collectIdentifiersNoNewlines rest
|
||||
in (name : names, final)
|
||||
collectIdentifiersNoNewlines (LIdentifier name : rest)
|
||||
| name `Set.notMember` reservedNames =
|
||||
let (names, final) = collectIdentifiersNoNewlines rest
|
||||
in (name : names, final)
|
||||
collectIdentifiersNoNewlines rest = ([], rest)
|
||||
|
||||
collectIdentifiersWithNewlines :: [LToken] -> ([String], [LToken])
|
||||
collectIdentifiersWithNewlines (LIdentifier name : rest) =
|
||||
let (names, final) = collectIdentifiersWithNewlines (dropNewlines rest)
|
||||
in (name : names, final)
|
||||
collectIdentifiersWithNewlines (LIdentifier name : rest)
|
||||
| name `Set.notMember` reservedNames =
|
||||
let (names, final) = collectIdentifiersWithNewlines (dropNewlines rest)
|
||||
in (name : names, final)
|
||||
collectIdentifiersWithNewlines rest = ([], rest)
|
||||
|
||||
consumeLambdaHead :: Context -> [String] -> TokParser ()
|
||||
@@ -194,7 +309,7 @@ pipeTopP =
|
||||
|
||||
pipeAtIndentP :: Int -> TokParser TricuAST
|
||||
pipeAtIndentP n =
|
||||
pipeChainP (appAtIndentP n) appNestedP
|
||||
pipeChainP (appAtIndentP n) (appAtIndentP n)
|
||||
|
||||
pipeNestedP :: TokParser TricuAST
|
||||
pipeNestedP =
|
||||
@@ -303,6 +418,7 @@ atomTopP = do
|
||||
case toks of
|
||||
LOpenParen : _ -> groupedP
|
||||
LOpenBracket : _ -> listP
|
||||
LIdentifier _ : LDot : _ -> namespacedVarP
|
||||
LNamespace _ : LDot : _ -> namespacedVarP
|
||||
LIdentifier "let" : _ -> letP
|
||||
LIdentifier "do" : _ -> doP
|
||||
@@ -354,6 +470,7 @@ listElementP = do
|
||||
case toks of
|
||||
LOpenParen : _ -> groupedP
|
||||
LOpenBracket : _ -> listP
|
||||
LIdentifier _ : LDot : _ -> namespacedVarP
|
||||
LNamespace _ : LDot : _ -> namespacedVarP
|
||||
LIdentifier "let" : _ -> letP
|
||||
LIdentifier "do" : _ -> doP
|
||||
@@ -486,14 +603,19 @@ namespacedVarP = do
|
||||
void (tok (== LDot) ".")
|
||||
nameTok <- tok isVar "identifier"
|
||||
case (nsTok, nameTok) of
|
||||
(LIdentifier ns, LIdentifier name) ->
|
||||
pure (SVar (ns ++ "." ++ name) Nothing)
|
||||
(LIdentifier ns, LIdentifierWithHash name hash) ->
|
||||
pure (SVar (ns ++ "." ++ name) (Just hash))
|
||||
(LNamespace ns, LIdentifier name) ->
|
||||
pure (SVar (ns ++ "." ++ name) Nothing)
|
||||
(LNamespace ns, LIdentifierWithHash name hash) ->
|
||||
pure (SVar (ns ++ "." ++ name) (Just hash))
|
||||
_ -> fail "internal parser error: expected namespaced identifier"
|
||||
where
|
||||
isNamespace (LNamespace _) = True
|
||||
isNamespace _ = False
|
||||
isNamespace (LIdentifier name) = name `Set.notMember` reservedNames
|
||||
isNamespace (LNamespace _) = True
|
||||
isNamespace _ = False
|
||||
|
||||
isVar (LIdentifier _) = True
|
||||
isVar (LIdentifierWithHash _ _) = True
|
||||
|
||||
816
src/REPL.hs
816
src/REPL.hs
@@ -1,675 +1,241 @@
|
||||
module REPL where
|
||||
|
||||
import ContentStore
|
||||
import Eval
|
||||
import Check (checkFileWithStore)
|
||||
import Eval (evalTricu, result)
|
||||
import FileEval
|
||||
import Lexer ()
|
||||
import Parser
|
||||
import Research
|
||||
import Wire (buildBundle, encodeBundle, importBundle)
|
||||
( ContractMode(..)
|
||||
, LoadedSource(..)
|
||||
, defaultStorePath
|
||||
, loadFileWithStoreMode
|
||||
)
|
||||
import Parser (parseTricu)
|
||||
import Research (EvaluatedForm(..), Env, formatT)
|
||||
import ContentStore (StorePath(..))
|
||||
|
||||
import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)
|
||||
import Control.Exception (SomeException, catch, displayException)
|
||||
import Control.Monad ()
|
||||
import Control.Monad (forever, when, forM_, foldM, unless)
|
||||
import Control.Monad.Catch (handle)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Class ()
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
||||
import Data.ByteString ()
|
||||
import Data.Char (isSpace)
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.IORef (newIORef, readIORef, writeIORef)
|
||||
import Data.List (dropWhileEnd, isPrefixOf, find)
|
||||
import Data.Maybe (isJust, fromJust)
|
||||
import Data.Time (getCurrentTime, diffUTCTime)
|
||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
||||
import Data.Time.Format (formatTime, defaultTimeLocale)
|
||||
import Control.Exception (SomeException, catch, displayException)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import Data.List (isPrefixOf, sort)
|
||||
import Data.Version (showVersion)
|
||||
import Database.SQLite.Simple (Connection, Only(..), query)
|
||||
import Paths_tricu (version)
|
||||
import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..), Color(..))
|
||||
import System.Console.Haskeline
|
||||
import System.Directory (doesFileExist, createDirectoryIfMissing)
|
||||
import System.FSNotify
|
||||
import System.FilePath (takeDirectory, (</>))
|
||||
import Text.Read (readMaybe)
|
||||
import System.Directory (doesFileExist)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO 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
|
||||
-- normal publishing mode or unchecked mode.
|
||||
data REPLState = REPLState
|
||||
{ replForm :: EvaluatedForm
|
||||
, replContentStore :: Maybe Connection
|
||||
, replWatchedFile :: Maybe FilePath
|
||||
, replSelectedVersions :: Map.Map String T.Text
|
||||
, replWatcherThread :: Maybe ThreadId
|
||||
{ replForm :: EvaluatedForm
|
||||
, replEnv :: Env
|
||||
, replStore :: StorePath
|
||||
, replContracts :: ContractMode
|
||||
, replEnvRef :: IORef Env
|
||||
}
|
||||
|
||||
repl :: IO ()
|
||||
repl = do
|
||||
conn <- ContentStore.initContentStore
|
||||
runInputT settings (withInterrupt (loop (REPLState Decode (Just conn) Nothing Map.empty Nothing)))
|
||||
store <- defaultStorePath
|
||||
envRef <- newIORef Map.empty
|
||||
let settings = Settings
|
||||
{ complete = completeRepl envRef
|
||||
, historyFile = Just "~/.local/state/tricu/history"
|
||||
, autoAddHistory = True
|
||||
}
|
||||
runInputT settings (loop (REPLState Decode Map.empty store EnforceContracts envRef))
|
||||
where
|
||||
settings :: Settings IO
|
||||
settings = Settings
|
||||
{ complete = completeWord Nothing " \t" completeCommands
|
||||
, historyFile = Just "~/.local/state/tricu/history"
|
||||
, autoAddHistory = True
|
||||
}
|
||||
|
||||
completeCommands :: String -> IO [Completion]
|
||||
completeCommands str = return $ map simpleCompletion $
|
||||
filter (str `isPrefixOf`) commands
|
||||
where
|
||||
commands = [ "!exit"
|
||||
, "!output"
|
||||
, "!import"
|
||||
, "!clear"
|
||||
, "!reset"
|
||||
, "!help"
|
||||
, "!definitions"
|
||||
, "!watch"
|
||||
, "!refresh"
|
||||
, "!versions"
|
||||
, "!select"
|
||||
, "!tag"
|
||||
, "!export"
|
||||
, "!bundleimport"
|
||||
]
|
||||
|
||||
loop :: REPLState -> InputT IO ()
|
||||
loop state = handle (\Interrupt -> interruptHandler state Interrupt) $ do
|
||||
loop state = do
|
||||
minput <- getInputLine "tricu < "
|
||||
case minput of
|
||||
Nothing -> return ()
|
||||
Just s
|
||||
| strip s == "" -> loop state
|
||||
| strip s == "!exit" -> outputStrLn "Exiting tricu"
|
||||
| strip s == "!clear" -> do
|
||||
liftIO $ putStr "\ESC[2J\ESC[H"
|
||||
loop state
|
||||
| strip s == "!reset" -> do
|
||||
outputStrLn "Selected versions reset"
|
||||
loop state { replSelectedVersions = Map.empty }
|
||||
| strip s == "!help" -> do
|
||||
outputStrLn $ "tricu version " ++ showVersion version
|
||||
outputStrLn "Available commands:"
|
||||
outputStrLn " !exit - Exit the REPL"
|
||||
outputStrLn " !clear - Clear the screen"
|
||||
outputStrLn " !reset - Reset preferences for selected versions"
|
||||
outputStrLn " !help - Show tricu version and available commands"
|
||||
outputStrLn " !output - Change output format (tree|fsl|ast|ternary|ascii|decode)"
|
||||
outputStrLn " !definitions - List all defined terms in the content store"
|
||||
outputStrLn " !import - Import definitions from file to the content store"
|
||||
outputStrLn " !watch - Watch a file for changes, evaluate terms, and store them"
|
||||
outputStrLn " !versions - Show all versions of a term by name"
|
||||
outputStrLn " !select - Select a specific version of a term for subsequent lookups"
|
||||
outputStrLn " !tag - Add or update a tag for a term by hash or name"
|
||||
outputStrLn " !export - Export a term bundle to file (hash, file)"
|
||||
outputStrLn " !bundleimport- Import a bundle file into the content store"
|
||||
loop state
|
||||
| strip s == "!output" -> handleOutput state
|
||||
| strip s == "!definitions" -> handleDefinitions state
|
||||
| "!import" `isPrefixOf` strip s -> handleImport state
|
||||
| "!watch" `isPrefixOf` strip s -> handleWatch state
|
||||
| strip s == "!refresh" -> handleRefresh state
|
||||
| "!versions" `isPrefixOf` strip s -> handleVersions state
|
||||
| "!select" `isPrefixOf` strip s -> handleSelect state
|
||||
| "!tag" `isPrefixOf` strip s -> handleTag state
|
||||
| "!export" `isPrefixOf` strip s -> handleExport state
|
||||
| "!bundleimport" `isPrefixOf` strip s -> handleBundleImport state
|
||||
| take 2 s == "--" -> loop state
|
||||
| otherwise -> do
|
||||
evalResult <- liftIO $ catch
|
||||
(processInput state s)
|
||||
(errorHandler state)
|
||||
loop evalResult
|
||||
Just raw -> do
|
||||
let s = strip raw
|
||||
case s of
|
||||
"" -> loop state
|
||||
"!exit" -> outputStrLn "Exiting tricu"
|
||||
"!clear" -> liftIO (putStr "\ESC[2J\ESC[H") >> loop state
|
||||
"!reset" -> do
|
||||
liftIO $ writeIORef (replEnvRef state) Map.empty
|
||||
outputStrLn "Environment reset"
|
||||
loop state { replEnv = Map.empty }
|
||||
"!help" -> printHelp >> loop state
|
||||
"!output" -> handleOutput state
|
||||
"!env" -> handleEnv state >> loop state
|
||||
_ | "!load" `isPrefixOf` s -> handleLoad state (strip $ drop 5 s)
|
||||
| "!check" `isPrefixOf` s -> handleCheck state (strip $ drop 6 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)
|
||||
| take 2 s == "--" -> loop state
|
||||
| otherwise -> do
|
||||
next <- liftIO $ catch (processInput state raw) (errorHandler state)
|
||||
loop next
|
||||
|
||||
printHelp :: InputT IO ()
|
||||
printHelp = do
|
||||
outputStrLn $ "tricu version " ++ showVersion version
|
||||
outputStrLn "Available commands:"
|
||||
outputStrLn " !exit - Exit the REPL"
|
||||
outputStrLn " !clear - Clear the screen"
|
||||
outputStrLn " !reset - Reset the in-memory environment"
|
||||
outputStrLn " !help - Show this help"
|
||||
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 " !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"
|
||||
outputStrLn " !env - List names currently in the REPL environment"
|
||||
|
||||
handleOutput :: REPLState -> InputT IO ()
|
||||
handleOutput state = do
|
||||
let formats = [Decode, Tree, FSL, AST, Ternary, Ascii, Number, StringLit]
|
||||
let formats = outputFormats
|
||||
outputStrLn "Available output formats:"
|
||||
mapM_ (\(i, f) -> outputStrLn $ show (i :: Int) ++ ". " ++ show f)
|
||||
(zip [1..] formats)
|
||||
|
||||
evalResult <- runMaybeT $ do
|
||||
input <- MaybeT $ getInputLine "Select output format (1-8) < "
|
||||
case reads input of
|
||||
[(n, "")] | n >= 1 && n <= 8 ->
|
||||
return $ formats !! (n-1)
|
||||
_ -> MaybeT $ return Nothing
|
||||
|
||||
case evalResult of
|
||||
Nothing -> do
|
||||
outputStrLn "Invalid selection. Keeping current output format."
|
||||
loop state
|
||||
Just newForm -> do
|
||||
input <- getInputLine "Select output format (1-8) < "
|
||||
case input >>= readMaybeInt of
|
||||
Just n | n >= 1 && n <= length formats -> do
|
||||
let newForm = formats !! (n - 1)
|
||||
outputStrLn $ "Output format changed to: " ++ show newForm
|
||||
loop state { replForm = newForm }
|
||||
_ -> outputStrLn "Invalid selection. Keeping current output format." >> loop state
|
||||
|
||||
handleDefinitions :: REPLState -> InputT IO ()
|
||||
handleDefinitions state = case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
terms <- liftIO $ ContentStore.listStoredTerms conn
|
||||
|
||||
if null terms
|
||||
then do
|
||||
liftIO $ printWarning "No terms in content store."
|
||||
loop state
|
||||
else do
|
||||
liftIO $ do
|
||||
printSuccess $ "Content store contains " ++ show (length terms) ++ " terms:"
|
||||
handleFormat :: REPLState -> String -> InputT IO ()
|
||||
handleFormat state arg =
|
||||
case readEvaluatedForm arg of
|
||||
Just form -> outputStrLn ("Output format changed to: " ++ show form) >> loop state { replForm = form }
|
||||
Nothing -> outputStrLn "Usage: !format tree|fsl|ast|ternary|ascii|decode|number|string" >> loop state
|
||||
|
||||
let maxNameWidth = maximum $ map (length . T.unpack . termNames) terms
|
||||
|
||||
forM_ terms $ \term -> do
|
||||
let namesStr = T.unpack (termNames term)
|
||||
hash = termHash term
|
||||
padding = replicate (maxNameWidth - length namesStr) ' '
|
||||
|
||||
liftIO $ do
|
||||
putStr " "
|
||||
printVariable namesStr
|
||||
putStr padding
|
||||
putStr " [hash: "
|
||||
displayColoredHash hash
|
||||
putStrLn "]"
|
||||
|
||||
tags <- ContentStore.termToTags conn hash
|
||||
unless (null tags) $ displayTags tags
|
||||
|
||||
loop state
|
||||
|
||||
handleImport :: REPLState -> InputT IO ()
|
||||
handleImport state = do
|
||||
let fset = setComplete completeFilename defaultSettings
|
||||
filename <- runInputT fset $ getInputLineWithInitial "File to import: " ("", "")
|
||||
case filename of
|
||||
Nothing -> loop state
|
||||
Just f -> do
|
||||
let cleanFilename = strip f
|
||||
exists <- liftIO $ doesFileExist cleanFilename
|
||||
handleLoad :: REPLState -> String -> InputT IO ()
|
||||
handleLoad state path
|
||||
| null path = outputStrLn "Usage: !load FILE" >> loop state
|
||||
| otherwise = do
|
||||
exists <- liftIO $ doesFileExist path
|
||||
if not exists
|
||||
then do
|
||||
liftIO $ printError $ "File not found: " ++ cleanFilename
|
||||
then outputStrLn ("File not found: " ++ path) >> loop state
|
||||
else do
|
||||
loaded <- liftIO $ loadFileWithStoreMode (replContracts state) (replStore state) path
|
||||
let env' = evalTricu (Map.union (loadedImports loaded) (replEnv state)) (loadedAst loaded)
|
||||
liftIO $ writeIORef (replEnvRef state) env'
|
||||
outputStrLn $ "Loaded " ++ path
|
||||
loop state { replEnv = env' }
|
||||
|
||||
handleCheck :: REPLState -> String -> InputT IO ()
|
||||
handleCheck state path
|
||||
| null path = outputStrLn "Usage: !check FILE" >> loop state
|
||||
| otherwise = do
|
||||
exists <- liftIO $ doesFileExist path
|
||||
if not exists
|
||||
then outputStrLn ("File not found: " ++ path) >> loop state
|
||||
else do
|
||||
output <- liftIO $ checkFileWithStore (replStore state) path
|
||||
outputStrLn output
|
||||
loop state
|
||||
else importFile state cleanFilename
|
||||
|
||||
importFile :: REPLState -> String -> InputT IO ()
|
||||
importFile state cleanFilename = do
|
||||
_code <- liftIO $ readFile cleanFilename
|
||||
case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
env <- liftIO $ evaluateFile cleanFilename
|
||||
|
||||
liftIO $ do
|
||||
printSuccess $ "Importing file: " ++ cleanFilename
|
||||
let defs = Map.toList $ Map.delete "!result" env
|
||||
|
||||
importedCount <- foldM (\count (name, term) -> do
|
||||
hash <- ContentStore.storeTerm conn [name] term
|
||||
printSuccess $ "Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
|
||||
return (count + (1 :: Int))
|
||||
) 0 defs
|
||||
|
||||
printSuccess $ "Imported " ++ show importedCount ++ " definitions successfully"
|
||||
|
||||
handleStore :: REPLState -> String -> InputT IO ()
|
||||
handleStore state path
|
||||
| null path = do
|
||||
outputStrLn $ "Store: " ++ storePathString (replStore state)
|
||||
loop state
|
||||
| otherwise = do
|
||||
outputStrLn $ "Store changed to: " ++ path
|
||||
loop state { replStore = StorePath path }
|
||||
|
||||
handleWatch :: REPLState -> InputT IO ()
|
||||
handleWatch state = do
|
||||
dbPath <- liftIO ContentStore.getContentStorePath
|
||||
let filepath = takeDirectory dbPath </> "scratch.tri"
|
||||
let dirPath = takeDirectory filepath
|
||||
handleUnchecked :: REPLState -> String -> InputT IO ()
|
||||
handleUnchecked state arg = setUnchecked state arg
|
||||
|
||||
liftIO $ createDirectoryIfMissing True dirPath
|
||||
setUnchecked :: REPLState -> String -> InputT IO ()
|
||||
setUnchecked state arg = case arg of
|
||||
"" -> reportContracts state >> loop state
|
||||
"on" -> setMode IgnoreContracts
|
||||
"off" -> setMode EnforceContracts
|
||||
_ -> outputStrLn "Usage: !unchecked [on|off]" >> loop state
|
||||
where
|
||||
setMode mode = do
|
||||
outputStrLn $ contractModeMessage mode
|
||||
loop state { replContracts = mode }
|
||||
|
||||
fileExists <- liftIO $ doesFileExist filepath
|
||||
unless fileExists $ liftIO $ writeFile filepath "-- tricu scratch file\n\n"
|
||||
reportContracts :: REPLState -> InputT IO ()
|
||||
reportContracts state = outputStrLn $ contractModeMessage (replContracts state)
|
||||
|
||||
outputStrLn $ "Using scratch file: " ++ filepath
|
||||
|
||||
when (isJust (replWatcherThread state)) $ do
|
||||
outputStrLn "Stopping previous file watch"
|
||||
liftIO $ killThread (fromJust $ replWatcherThread state)
|
||||
|
||||
outputStrLn $ "Starting to watch file: " ++ filepath
|
||||
outputStrLn "Press Ctrl+C to stop watching and return to REPL"
|
||||
|
||||
liftIO $ processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state)
|
||||
|
||||
lastProcessedRef <- liftIO $ newIORef =<< getCurrentTime
|
||||
|
||||
watcherId <- liftIO $ forkIO $ withManager $ \mgr -> do
|
||||
_stopAction <- watchDir mgr dirPath (\ev -> eventPath ev == filepath) $ \_ -> do
|
||||
now <- getCurrentTime
|
||||
lastProcessed <- readIORef lastProcessedRef
|
||||
when (diffUTCTime now lastProcessed > 0.5) $ do
|
||||
putStrLn $ "\nFile changed: " ++ filepath
|
||||
processWatchedFile filepath (replContentStore state) (replSelectedVersions state) (replForm state)
|
||||
writeIORef lastProcessedRef now
|
||||
forever $ threadDelay 1000000
|
||||
|
||||
watchLoop state { replWatchedFile = Just filepath, replWatcherThread = Just watcherId }
|
||||
|
||||
_handleUnwatch :: REPLState -> InputT IO ()
|
||||
_handleUnwatch state = case replWatchedFile state of
|
||||
Nothing -> do
|
||||
outputStrLn "No file is currently being watched"
|
||||
loop state
|
||||
Just path -> do
|
||||
outputStrLn $ "Stopped watching " ++ path
|
||||
when (isJust (replWatcherThread state)) $ do
|
||||
liftIO $ killThread (fromJust $ replWatcherThread state)
|
||||
loop state { replWatchedFile = Nothing, replWatcherThread = Nothing }
|
||||
|
||||
handleRefresh :: REPLState -> InputT IO ()
|
||||
handleRefresh state = case replContentStore state of
|
||||
Nothing -> do
|
||||
outputStrLn "Content store not initialized"
|
||||
loop state
|
||||
Just _conn -> do
|
||||
outputStrLn "Environment refreshed from content store (definitions are live)"
|
||||
loop state
|
||||
|
||||
handleVersions :: REPLState -> InputT IO ()
|
||||
handleVersions state = case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
liftIO $ printPrompt "Term name: "
|
||||
nameInput <- getInputLine ""
|
||||
case nameInput of
|
||||
Nothing -> loop state
|
||||
Just n -> do
|
||||
let termName = strip n
|
||||
versions <- liftIO $ ContentStore.termVersions conn termName
|
||||
if null versions
|
||||
then liftIO $ printError $ "No versions found for term: " ++ termName
|
||||
else do
|
||||
liftIO $ do
|
||||
printKeyword "Versions of "
|
||||
printVariable termName
|
||||
putStrLn ":"
|
||||
|
||||
forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do
|
||||
tags <- ContentStore.termToTags conn hash
|
||||
putStr $ show (i :: Int) ++ ". "
|
||||
displayColoredHash hash
|
||||
putStr $ " (" ++ formatTimestamp ts ++ ")"
|
||||
unless (null tags) $ do
|
||||
putStr " ["
|
||||
printKeyword "Tags: "
|
||||
forM_ (zip [0..] tags) $ \(j, tag) -> do
|
||||
printTag (T.unpack tag)
|
||||
when (j < length tags - 1) $ putStr ", "
|
||||
putStr "]"
|
||||
putStrLn ""
|
||||
loop state
|
||||
|
||||
handleSelect :: REPLState -> InputT IO ()
|
||||
handleSelect state = case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
liftIO $ printPrompt "Term name: "
|
||||
nameInput <- getInputLine ""
|
||||
case nameInput of
|
||||
Nothing -> loop state
|
||||
Just n -> do
|
||||
let cleanName = strip n
|
||||
versions <- liftIO $ ContentStore.termVersions conn cleanName
|
||||
if null versions
|
||||
then do
|
||||
liftIO $ printError $ "No versions found for term: " ++ cleanName
|
||||
loop state
|
||||
else do
|
||||
liftIO $ do
|
||||
printKeyword "Versions of "
|
||||
printVariable cleanName
|
||||
putStrLn ":"
|
||||
|
||||
forM_ (zip [1..] versions) $ \(i, (hash, _, ts)) -> do
|
||||
tags <- ContentStore.termToTags conn hash
|
||||
putStr $ show (i :: Int) ++ ". "
|
||||
displayColoredHash hash
|
||||
putStr $ " (" ++ formatTimestamp ts ++ ")"
|
||||
unless (null tags) $ do
|
||||
putStr " ["
|
||||
printKeyword "Tags: "
|
||||
forM_ (zip [0..] tags) $ \(j, tag) -> do
|
||||
printTag (T.unpack tag)
|
||||
when (j < length tags - 1) $ putStr ", "
|
||||
putStr "]"
|
||||
putStrLn ""
|
||||
|
||||
liftIO $ printPrompt "Select version (number or full hash, Enter to cancel): "
|
||||
choiceInput <- getInputLine ""
|
||||
let choice = strip <$> choiceInput
|
||||
|
||||
selectedHash <- case choice of
|
||||
Just selectedStr | not (null selectedStr) -> do
|
||||
case readMaybe selectedStr :: Maybe Int of
|
||||
Just idx | idx > 0 && idx <= length versions -> do
|
||||
let (h, _, _) = versions !! (idx - 1)
|
||||
return $ Just h
|
||||
_ -> do
|
||||
let potentialHash = T.pack selectedStr
|
||||
let foundByHash = find (\(h, _, _) -> T.isPrefixOf potentialHash h) versions
|
||||
case foundByHash of
|
||||
Just (h, _, _) -> return $ Just h
|
||||
Nothing -> do
|
||||
liftIO $ printError "Invalid selection or hash not found in list."
|
||||
return Nothing
|
||||
_ -> return Nothing
|
||||
|
||||
case selectedHash of
|
||||
Just hashToSelect -> do
|
||||
let newState = state { replSelectedVersions =
|
||||
Map.insert cleanName hashToSelect (replSelectedVersions state) }
|
||||
liftIO $ do
|
||||
printSuccess "Selected version "
|
||||
displayColoredHash hashToSelect
|
||||
putStr " for term "
|
||||
printVariable cleanName
|
||||
putStrLn ""
|
||||
loop newState
|
||||
Nothing -> loop state
|
||||
|
||||
handleTag :: REPLState -> InputT IO ()
|
||||
handleTag state = case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
liftIO $ printPrompt "Term hash (full or prefix) or name (most recent version will be used): "
|
||||
identInput <- getInputLine ""
|
||||
case identInput of
|
||||
Nothing -> loop state
|
||||
Just ident -> do
|
||||
let cleanIdent = strip ident
|
||||
|
||||
mFullHash <- liftIO $ resolveIdentifierToHash conn cleanIdent
|
||||
|
||||
case mFullHash of
|
||||
Nothing -> do
|
||||
liftIO $ printError $ "Could not resolve identifier: " ++ cleanIdent
|
||||
loop state
|
||||
Just fullHash -> do
|
||||
liftIO $ do
|
||||
putStr "Tagging term with hash: "
|
||||
displayColoredHash fullHash
|
||||
putStrLn ""
|
||||
tags <- liftIO $ ContentStore.termToTags conn fullHash
|
||||
unless (null tags) $ do
|
||||
liftIO $ do
|
||||
printKeyword "Existing tags:"
|
||||
displayTags tags
|
||||
|
||||
liftIO $ printPrompt "Tag to add/set: "
|
||||
tagValueInput <- getInputLine ""
|
||||
case tagValueInput of
|
||||
Nothing -> loop state
|
||||
Just tv -> do
|
||||
let tagVal = T.pack (strip tv)
|
||||
liftIO $ do
|
||||
ContentStore.setTag conn fullHash tagVal
|
||||
printSuccess $ "Tag '"
|
||||
printTag (T.unpack tagVal)
|
||||
putStr "' set for term with hash "
|
||||
displayColoredHash fullHash
|
||||
putStrLn ""
|
||||
loop state
|
||||
|
||||
resolveIdentifierToHash :: Connection -> String -> IO (Maybe T.Text)
|
||||
resolveIdentifierToHash conn ident
|
||||
| T.pack "#" `T.isInfixOf` T.pack ident = do
|
||||
let hashPrefix = T.pack ident
|
||||
matchingHashes <- liftIO $ query conn "SELECT hash FROM terms WHERE hash LIKE ?" (Only (hashPrefix <> "%")) :: IO [Only T.Text]
|
||||
case matchingHashes of
|
||||
[Only fullHash] -> return $ Just fullHash
|
||||
[] -> do printError $ "No hash found starting with: " ++ T.unpack hashPrefix; return Nothing
|
||||
_ -> do printError $ "Ambiguous hash prefix: " ++ T.unpack hashPrefix; return Nothing
|
||||
| otherwise = do
|
||||
versions <- ContentStore.termVersions conn ident
|
||||
if null versions
|
||||
then do printError $ "No versions found for term name: " ++ ident; return Nothing
|
||||
else return $ Just $ (\(h,_,_) -> h) $ head versions
|
||||
|
||||
handleExport :: REPLState -> InputT IO ()
|
||||
handleExport state = do
|
||||
let fset = setComplete completeFilename defaultSettings
|
||||
hashInput <- runInputT fset $ getInputLineWithInitial "Hash or name: " ("", "")
|
||||
case hashInput of
|
||||
Nothing -> loop state
|
||||
Just hashStr -> do
|
||||
fileInput <- runInputT fset $ getInputLineWithInitial "Output file: " ("", "")
|
||||
case fileInput of
|
||||
Nothing -> loop state
|
||||
Just outFile -> case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
let cleanHash = strip hashStr
|
||||
hash <- liftIO $ do
|
||||
let h = T.pack cleanHash
|
||||
if '#' `T.elem` h
|
||||
then return h
|
||||
else do
|
||||
results <- query conn "SELECT hash FROM terms WHERE names LIKE ? LIMIT 1"
|
||||
(Only (h <> "%")) :: IO [Only T.Text]
|
||||
case results of
|
||||
[Only fullHash] -> return fullHash
|
||||
[] -> do
|
||||
results2 <- query conn "SELECT hash FROM terms WHERE hash LIKE ? LIMIT 1"
|
||||
(Only (h <> "%")) :: IO [Only T.Text]
|
||||
case results2 of
|
||||
[Only fullHash] -> return fullHash
|
||||
_ -> do
|
||||
printError $ "No term found matching: " ++ cleanHash
|
||||
return h
|
||||
_ -> do
|
||||
printError $ "Ambiguous match for: " ++ cleanHash
|
||||
return h
|
||||
maybeTree <- liftIO $ loadTree conn hash
|
||||
case maybeTree of
|
||||
Nothing -> do
|
||||
liftIO $ printError $ "Term not found in store: " ++ T.unpack hash
|
||||
loop state
|
||||
Just tree -> do
|
||||
let bundle = buildBundle [(T.pack "root", tree)]
|
||||
bundleData = encodeBundle bundle
|
||||
liftIO $ BL.writeFile outFile (BL.fromStrict bundleData)
|
||||
liftIO $ do
|
||||
printSuccess $ "Exported bundle with root "
|
||||
displayColoredHash hash
|
||||
putStrLn $ " to " ++ outFile
|
||||
loop state
|
||||
|
||||
handleBundleImport :: REPLState -> InputT IO ()
|
||||
handleBundleImport state = do
|
||||
let fset = setComplete completeFilename defaultSettings
|
||||
fileInput <- runInputT fset $ getInputLineWithInitial "Bundle file: " ("", "")
|
||||
case fileInput of
|
||||
Nothing -> loop state
|
||||
Just inFile -> case replContentStore state of
|
||||
Nothing -> do
|
||||
liftIO $ printError "Content store not initialized"
|
||||
loop state
|
||||
Just conn -> do
|
||||
exists <- liftIO $ doesFileExist inFile
|
||||
if not exists
|
||||
then do
|
||||
liftIO $ printError $ "File not found: " ++ inFile
|
||||
loop state
|
||||
else do
|
||||
bundleData <- liftIO $ BL.readFile inFile
|
||||
roots <- liftIO $ importBundle conn (BL.toStrict bundleData)
|
||||
liftIO $ do
|
||||
printSuccess $ "Imported " ++ show (length roots) ++ " root(s):"
|
||||
mapM_ (\r -> putStrLn $ " " ++ T.unpack r) roots
|
||||
loop state
|
||||
|
||||
interruptHandler :: REPLState -> Interrupt -> InputT IO ()
|
||||
interruptHandler state _ = do
|
||||
liftIO $ do
|
||||
printWarning "Interrupted with CTRL+C"
|
||||
printWarning "You can use the !exit command or CTRL+D to exit"
|
||||
loop state
|
||||
|
||||
errorHandler :: REPLState -> SomeException -> IO REPLState
|
||||
errorHandler state e = do
|
||||
printError $ "Error: " ++ displayException e
|
||||
return state
|
||||
handleEnv :: REPLState -> InputT IO ()
|
||||
handleEnv state =
|
||||
case sort (Map.keys (replEnv state)) of
|
||||
[] -> outputStrLn "Environment is empty"
|
||||
names -> mapM_ outputStrLn names
|
||||
|
||||
processInput :: REPLState -> String -> IO REPLState
|
||||
processInput state input = do
|
||||
let asts = parseTricu input
|
||||
case asts of
|
||||
[] -> return state
|
||||
_ -> case replContentStore state of
|
||||
Nothing -> do
|
||||
printError "Content store not initialized"
|
||||
return state
|
||||
Just conn -> do
|
||||
newState <- foldM (\s astNode -> do
|
||||
let varsInAst = Eval.findVarNames astNode
|
||||
foldM (\currentSelectionState varName ->
|
||||
if Map.member varName (replSelectedVersions currentSelectionState)
|
||||
then return currentSelectionState
|
||||
else do
|
||||
versions <- ContentStore.termVersions conn varName
|
||||
if length versions > 1
|
||||
then do
|
||||
let (latestHash, _, _) = head versions
|
||||
liftIO $ printWarning $ "Multiple versions of '" ++ varName ++ "' found. Using most recent."
|
||||
return currentSelectionState { replSelectedVersions = Map.insert varName latestHash (replSelectedVersions currentSelectionState) }
|
||||
else return currentSelectionState
|
||||
) s varsInAst
|
||||
) state asts
|
||||
let env' = evalTricu (replEnv state) (parseTricu input)
|
||||
writeIORef (replEnvRef state) env'
|
||||
putStrLn $ formatT (replForm state) (result env')
|
||||
return state { replEnv = env' }
|
||||
|
||||
forM_ asts $ \ast -> do
|
||||
case ast of
|
||||
SDef name [] body -> do
|
||||
evalResult <- evalAST (Just conn) (replSelectedVersions newState) body
|
||||
hash <- ContentStore.storeTerm conn [name] evalResult
|
||||
|
||||
liftIO $ do
|
||||
putStr "tricu > "
|
||||
printSuccess "Stored definition: "
|
||||
printVariable name
|
||||
putStr " with hash "
|
||||
displayColoredHash hash
|
||||
putStrLn ""
|
||||
|
||||
putStr "tricu > "
|
||||
printResult $ formatT (replForm newState) evalResult
|
||||
putStrLn ""
|
||||
errorHandler :: REPLState -> SomeException -> IO REPLState
|
||||
errorHandler state e = do
|
||||
putStrLn $ "Error: " ++ displayException e
|
||||
return state
|
||||
|
||||
_ -> do
|
||||
evalResult <- evalAST (Just conn) (replSelectedVersions newState) ast
|
||||
liftIO $ do
|
||||
putStr "tricu > "
|
||||
printResult $ formatT (replForm newState) evalResult
|
||||
putStrLn ""
|
||||
return newState
|
||||
completeRepl :: IORef Env -> CompletionFunc IO
|
||||
completeRepl envRef input@(left, _right)
|
||||
| commandWantsFile line = completeFilename input
|
||||
| "!" `isPrefixOf` line = completeWord Nothing " \t" completeCommands input
|
||||
| otherwise = completeWord Nothing termBreakChars completeTerms input
|
||||
where
|
||||
line = reverse left
|
||||
completeCommands str = return $ map simpleCompletion $
|
||||
filter (str `isPrefixOf`) commands
|
||||
completeTerms str = do
|
||||
env <- readIORef envRef
|
||||
return $ map simpleCompletion $
|
||||
filter (str `isPrefixOf`) (sort $ Map.keys env)
|
||||
commands =
|
||||
[ "!exit"
|
||||
, "!output"
|
||||
, "!format"
|
||||
, "!clear"
|
||||
, "!reset"
|
||||
, "!help"
|
||||
, "!load"
|
||||
, "!check"
|
||||
, "!store"
|
||||
, "!unchecked"
|
||||
, "!env"
|
||||
]
|
||||
commandWantsFile inputLine = any (`isPrefixOf` inputLine) ["!load ", "!check "]
|
||||
termBreakChars = " \t\n\r()[]{}\"'"
|
||||
|
||||
strip :: String -> String
|
||||
strip = dropWhileEnd isSpace . dropWhile isSpace
|
||||
outputFormats :: [EvaluatedForm]
|
||||
outputFormats = [Decode, Tree, FSL, AST, Ternary, Ascii, Number, StringLit]
|
||||
|
||||
watchLoop :: REPLState -> InputT IO ()
|
||||
watchLoop state = handle (\Interrupt -> do
|
||||
outputStrLn "\nStopped watching file"
|
||||
when (isJust (replWatcherThread state)) $ do
|
||||
liftIO $ killThread (fromJust $ replWatcherThread state)
|
||||
loop state { replWatchedFile = Nothing, replWatcherThread = Nothing }) $ do
|
||||
liftIO $ threadDelay 1000000
|
||||
watchLoop state
|
||||
readEvaluatedForm :: String -> Maybe EvaluatedForm
|
||||
readEvaluatedForm s = case s of
|
||||
"tree" -> Just Tree
|
||||
"fsl" -> Just FSL
|
||||
"ast" -> Just AST
|
||||
"ternary" -> Just Ternary
|
||||
"ascii" -> Just Ascii
|
||||
"decode" -> Just Decode
|
||||
"number" -> Just Number
|
||||
"string" -> Just StringLit
|
||||
_ -> Nothing
|
||||
|
||||
processWatchedFile :: FilePath -> Maybe Connection -> Map.Map String T.Text -> EvaluatedForm -> IO ()
|
||||
processWatchedFile filepath mconn selectedVersions outputForm = do
|
||||
content <- readFile filepath
|
||||
let asts = parseTricu content
|
||||
contractModeMessage :: ContractMode -> String
|
||||
contractModeMessage EnforceContracts = "Contracts: on"
|
||||
contractModeMessage IgnoreContracts = "Contracts: off (unchecked eval)"
|
||||
|
||||
case mconn of
|
||||
Nothing -> putStrLn "Content store not initialized for watched file processing."
|
||||
Just conn -> do
|
||||
forM_ asts $ \ast -> case ast of
|
||||
SDef name [] body -> do
|
||||
evalResult <- evalAST (Just conn) selectedVersions body
|
||||
hash <- ContentStore.storeTerm conn [name] evalResult
|
||||
putStrLn $ "tricu > Stored definition: " ++ name ++ " with hash " ++ T.unpack hash
|
||||
putStrLn $ "tricu > " ++ name ++ " = " ++ formatT outputForm evalResult
|
||||
_ -> do
|
||||
evalResult <- evalAST (Just conn) selectedVersions ast
|
||||
putStrLn $ "tricu > Result: " ++ formatT outputForm evalResult
|
||||
putStrLn $ "tricu > Processed file: " ++ filepath
|
||||
storePathString :: StorePath -> FilePath
|
||||
storePathString (StorePath path) = path
|
||||
|
||||
formatTimestamp :: Integer -> String
|
||||
formatTimestamp ts = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" (posixSecondsToUTCTime (fromIntegral ts))
|
||||
strip :: String -> String
|
||||
strip = f . f
|
||||
where f = reverse . dropWhile (`elem` [' ', '\t', '\n', '\r'])
|
||||
|
||||
displayColoredHash :: T.Text -> IO ()
|
||||
displayColoredHash hash = do
|
||||
let (prefix, rest) = T.splitAt 16 hash
|
||||
setSGR [SetColor Foreground Vivid Cyan]
|
||||
putStr $ T.unpack prefix
|
||||
setSGR [SetColor Foreground Dull White]
|
||||
putStr $ T.unpack rest
|
||||
setSGR [Reset]
|
||||
|
||||
withColor :: ColorIntensity -> Color -> IO () -> IO ()
|
||||
withColor intensity color action = do
|
||||
setSGR [SetColor Foreground intensity color]
|
||||
action
|
||||
setSGR [Reset]
|
||||
|
||||
printColored :: ColorIntensity -> Color -> String -> IO ()
|
||||
printColored intensity color text = withColor intensity color $ putStr text
|
||||
|
||||
printlnColored :: ColorIntensity -> Color -> String -> IO ()
|
||||
printlnColored intensity color text = withColor intensity color $ putStrLn text
|
||||
|
||||
printSuccess :: String -> IO ()
|
||||
printSuccess = printlnColored Vivid Green
|
||||
|
||||
printError :: String -> IO ()
|
||||
printError = printlnColored Vivid Red
|
||||
|
||||
printWarning :: String -> IO ()
|
||||
printWarning = printlnColored Vivid Yellow
|
||||
|
||||
printPrompt :: String -> IO ()
|
||||
printPrompt = printColored Vivid Blue
|
||||
|
||||
printVariable :: String -> IO ()
|
||||
printVariable = printColored Vivid Magenta
|
||||
|
||||
printTag :: String -> IO ()
|
||||
printTag = printColored Vivid Yellow
|
||||
|
||||
printKeyword :: String -> IO ()
|
||||
printKeyword = printColored Vivid Blue
|
||||
|
||||
printResult :: String -> IO ()
|
||||
printResult = printColored Dull White
|
||||
|
||||
displayTags :: [T.Text] -> IO ()
|
||||
displayTags [] = return ()
|
||||
displayTags tags = do
|
||||
putStr " Tags: "
|
||||
forM_ (zip [0..] tags) $ \(i, tag) -> do
|
||||
printTag (T.unpack tag)
|
||||
when (i < length tags - 1) $ putStr ", "
|
||||
putStrLn ""
|
||||
readMaybeInt :: String -> Maybe Int
|
||||
readMaybeInt s = case reads s of
|
||||
[(n, "")] -> Just n
|
||||
_ -> Nothing
|
||||
|
||||
@@ -1,3 +1,5 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module Research where
|
||||
|
||||
import Crypto.Hash (hash, SHA256, Digest)
|
||||
@@ -17,6 +19,45 @@ import qualified Data.Text as T
|
||||
data T = Leaf | Stem T | Fork T T
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- View Contract source annotations
|
||||
data ViewRef
|
||||
= ViewRefInt Integer
|
||||
| ViewRefText String
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data ViewType
|
||||
= VTName String
|
||||
| VTRefRaw ViewRef
|
||||
| VTList ViewType
|
||||
| VTMaybe ViewType
|
||||
| VTPair ViewType ViewType
|
||||
| VTResult ViewType ViewType
|
||||
| VTGuarded ViewType T
|
||||
| VTFn [ViewType] ViewType
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
pattern VTRef :: Integer -> ViewType
|
||||
pattern VTRef n = VTRefRaw (ViewRefInt n)
|
||||
|
||||
pattern VTRefText :: String -> ViewType
|
||||
pattern VTRefText s = VTRefRaw (ViewRefText s)
|
||||
|
||||
{-# COMPLETE VTName, VTRef, VTRefText, VTList, VTMaybe, VTPair, VTResult, VTGuarded, VTFn #-}
|
||||
|
||||
data ViewExpr
|
||||
= VEName String
|
||||
| VEInt Integer
|
||||
| VEString String
|
||||
| VEList [ViewExpr]
|
||||
| VEApp ViewExpr ViewExpr
|
||||
| VERaw String
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data DefArg
|
||||
= DefBinder String (Maybe ViewExpr)
|
||||
| DefPhantom ViewExpr
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- Abstract Syntax Tree for tricu
|
||||
data TricuAST
|
||||
= SVar String (Maybe String)
|
||||
@@ -24,6 +65,7 @@ data TricuAST
|
||||
| SStr String
|
||||
| SList [TricuAST]
|
||||
| SDef String [String] TricuAST
|
||||
| SDefAnn String [DefArg] (Maybe ViewExpr) TricuAST
|
||||
| SApp TricuAST TricuAST
|
||||
| TLeaf
|
||||
| TStem TricuAST
|
||||
@@ -41,6 +83,8 @@ data LToken
|
||||
| LNamespace String
|
||||
| LImport String String
|
||||
| LAssign
|
||||
| LAssignAt
|
||||
| LAt
|
||||
| LColon
|
||||
| LDot
|
||||
| LOpenParen
|
||||
@@ -65,7 +109,6 @@ type Env = Map.Map String T
|
||||
|
||||
-- Merkle DAG Node types
|
||||
-- Each Tree Calculus node becomes a content-addressed object.
|
||||
|
||||
type MerkleHash = Text
|
||||
|
||||
data Node
|
||||
|
||||
23
src/Wire.hs
23
src/Wire.hs
@@ -16,11 +16,10 @@ module Wire
|
||||
, decodeBundle
|
||||
, verifyBundle
|
||||
, buildBundle
|
||||
, importBundle
|
||||
, reconstructBundleTerms
|
||||
, defaultExportNames
|
||||
) where
|
||||
|
||||
import ContentStore (storeTerm)
|
||||
import Research hiding (Node)
|
||||
|
||||
import Control.Monad (foldM, forM_, unless, when)
|
||||
@@ -41,7 +40,6 @@ import Data.Vector (Vector)
|
||||
import qualified Data.Vector as V
|
||||
import qualified Data.Vector.Mutable as MV
|
||||
import Data.Word (Word16, Word32, Word64, Word8)
|
||||
import Database.SQLite.Simple (Connection)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
@@ -774,11 +772,11 @@ verifyManifestConstraints manifest = do
|
||||
Left "manifest export has empty name"
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Import into content store
|
||||
-- Bundle reconstruction
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
reconstructTerms :: Seq BundleNode -> Vector T
|
||||
reconstructTerms nodes = V.create $ do
|
||||
reconstructBundleTerms :: Seq BundleNode -> Vector T
|
||||
reconstructBundleTerms nodes = V.create $ do
|
||||
let n = Seq.length nodes
|
||||
vec <- MV.new n
|
||||
forM_ (zip [0 :: Int ..] (Foldable.toList nodes)) $ \(i, node) -> do
|
||||
@@ -792,19 +790,6 @@ reconstructTerms nodes = V.create $ do
|
||||
MV.write vec i t
|
||||
return vec
|
||||
|
||||
importBundle :: Connection -> ByteString -> IO [Text]
|
||||
importBundle conn bs = case decodeBundle bs of
|
||||
Left err -> error $ "Wire.importBundle: " ++ err
|
||||
Right bundle -> case verifyBundle bundle of
|
||||
Left err -> error $ "Wire.importBundle verify: " ++ err
|
||||
Right () -> do
|
||||
let terms = reconstructTerms (bundleNodes bundle)
|
||||
forM_ (manifestExports $ bundleManifest bundle) $ \exp -> do
|
||||
let term = terms V.! fromIntegral (exportRoot exp)
|
||||
_ <- storeTerm conn [T.unpack $ exportName exp] term
|
||||
return ()
|
||||
return $ map exportName $ manifestExports $ bundleManifest bundle
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- Primitive binary helpers
|
||||
-- ---------------------------------------------------------------------------
|
||||
|
||||
Reference in New Issue
Block a user