James/tricu
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Attach contracts to definitions

Browse Source 
Contracts now live directly on definitions via @ / =@ annotations and
travel automatically with exported values.

- Remove !export from lexer/parser/AST/evaluator/manifest/resolver and CLI.
- Simplify workspace module export logic: export all top-level local
  definitions by default.
- Update Frontend.ContractDesugar:
  - Named binder annotations (x@nat?) expand to per-argument withContract.
  - Phantom annotations (@nat?) expand to a local raw helper plus a wrapper,
    keeping fixed points shared and only depending on withContract.
- Merge lib/guardedBase.tri into lib/base.tri and annotate partial/sensitive
  base functions: head, tail, last, add, sub, mul, div, mod, pow, min,
  max, length, sum, product.
- Add check contract helper to lib/base.tri.
- Update demos/contractBasics.tri and README to reflect @/=@-only design.
- Update test suite: remove guardedBase import, replace explicit !export
  test with a test verifying that contract annotations on an exported
  definition are enforced on import.
- Fix remaining base.tri definitions (div/mod/pow) to stay point-free.
This commit is contained in:
James Eversole
2026-09-01 10:33:54 -05:00
parent 229ba34af4
commit e595763f91
15 changed files with 105 additions and 198 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
src/Eval.hs
View File

@@ -68,14 +68,10 @@ evalTricu env x = go env (reorderDefs env (map recoverParams (desugarContracts x
where
go env' [] = env'
go env' [def] =
let updatedEnv = evalSingle (trace ("evaluating: " ++ defName' def) env') def
let updatedEnv = evalSingle env' def
in Map.insert "!result" (result updatedEnv) updatedEnv
go env' (def:xs) =
evalTricu (evalSingle (trace ("evaluating: " ++ defName' def) env') def) xs
defName' (SDef name _ _) = name
defName' (SDefAnn name _ _ _) = name
defName' _ = "<expr>"
evalTricu (evalSingle env' def) xs
evalASTSync :: Env -> TricuAST -> T
evalASTSync env term = case term of
@@ -209,8 +205,6 @@ freeVars (SDefAnn _ args ret body) =
, Set.singleton "withContract"
])
(Set.fromList (annotatedBinders args))
freeVars (SExport _ Nothing) = Set.empty
freeVars (SExport _ (Just c)) = freeVarsViewExpr c
freeVars (TStem t) = freeVars t
freeVars (TFork t u) = Set.union (freeVars t) (freeVars u)
freeVars (SList xs) = foldMap freeVars xs

29
src/FileEval.hs
View File

@@ -16,8 +16,7 @@ module FileEval
) where
import ContentStore
import Eval (evalASTSync, evalTricu, freeVars, result)
import Frontend.ContractDesugar (viewExprToAst)
import Eval (evalTricu, freeVars, result)
import Lexer
import Module.Manifest
import Module.Resolver
@@ -159,37 +158,25 @@ buildWorkspaceModule ctx store moduleName sourcePath = do
loaded <- loadFile' ctx sourcePath
let asts = loadedAst loaded
env = evalTricu (loadedImports loaded) asts
explicitExports = topLevelExports asts
localNames = topLevelDefinitions asts
names = if not (null explicitExports)
then explicitExports
else if null localNames
then map (\n -> (n, Nothing)) (filter (/= "!result") (Map.keys env))
else map (\n -> (n, Nothing)) localNames
names = if null localNames
then filter (/= "!result") (Map.keys env)
else localNames
exports <- mapM (buildExport env) names
manifestHash <- putManifest store (ModuleManifest [] exports)
writeAlias store ModuleAlias (T.pack moduleName) (ObjectRef (unDomain manifestDomain) manifestHash)
where
buildExport env (name, mContract) = case Map.lookup name env of
buildExport env name = case Map.lookup name env of
Nothing -> errorWithoutStackTrace $
"Workspace module export not found after evaluation: " ++ name
Just term -> do
rootRef <- putTreeTerm store term
mContractRef <- case mContract of
Nothing -> return Nothing
Just c -> do
cterm <- evaluateContract env c
chash <- putTreeTerm store cterm
return (Just (ObjectRef (unDomain treeTermDomain) chash))
return ModuleExport
{ moduleExportName = T.pack name
, moduleExportObject = ObjectRef (unDomain treeTermDomain) rootRef
, moduleExportAbi = "arboricx.abi.tree.v1"
, moduleExportContract = mContractRef
}
evaluateContract env c = return $ evalASTSync env (viewExprToAst c)
topLevelDefinitions :: [TricuAST] -> [String]
topLevelDefinitions = mapMaybe go
where
@@ -197,12 +184,6 @@ topLevelDefinitions = mapMaybe go
go (SDefAnn name _ _ _) = Just name
go _ = Nothing
topLevelExports :: [TricuAST] -> [(String, Maybe ViewExpr)]
topLevelExports = mapMaybe go
where
go (SExport name mContract) = Just (name, mContract)
go _ = Nothing
defaultStorePath :: IO StorePath
defaultStorePath = do
home <- getHomeDirectory

63
src/Frontend/ContractDesugar.hs
View File

@@ -10,39 +10,54 @@ import Research
-- | Convert source-level contract annotations into runtime boundary checks.
--
-- A definition such as
-- Named binder annotations (e.g. @x@nat?) wrap each argument as it is
-- received and the result before it is returned.
--
-- addPos x@positive? y@positive? =@positive? (add x y)
--
-- is desugared to a plain definition whose body wraps every annotated
-- argument and the result with 'withContract' from the contract library:
--
-- addPos = \x -> withContract positive? x
-- (\x -> \y -> withContract positive? y
-- (\y -> withContract positive? (add x y)
-- (\r -> r)
-- (\msg _ -> msg))
-- (\msg _ -> msg))
-- (\msg _ -> msg)
--
-- This makes annotated source depend on the existing 'withContract' helper,
-- which is an ordinary 'tricu' function from 'lib/contracts.tri'. Files that
-- use annotations should import the contract library (or another library that
-- re-exports 'withContract').
-- Phantom annotations (e.g. @nat? on a point-free definition) are turned
-- into a fresh local raw value plus a wrapper definition that uses named
-- binder annotations. The raw value is bound with a local 'let' so that
-- fixed points (such as definitions built with 'y') are shared rather than
-- recreated on every call. The wrapper only needs 'withContract', which is
-- already required by any source-level annotation.
desugarContracts :: [TricuAST] -> [TricuAST]
desugarContracts asts = map desugarTopItem asts
desugarContracts asts = concatMap desugarTopItem asts
where
desugarTopItem (SDefAnn name args ret body) = desugarDefAnn name args ret body
desugarTopItem other = other
desugarTopItem other = [other]
desugarDefAnn :: String -> [DefArg] -> Maybe ViewExpr -> TricuAST -> TricuAST
desugarDefAnn name args ret body = SDef name [] (wrapArgs args body')
-- | Fresh internal name for the raw, contract-free helper introduced by
-- phantom annotations. It is bound locally with 'SLet' so it never escapes
-- into the final environment.
rawNameFor :: String -> String
rawNameFor name = "_" ++ name ++ "_raw"
desugarDefAnn :: String -> [DefArg] -> Maybe ViewExpr -> TricuAST -> [TricuAST]
desugarDefAnn name args ret body
| all isPhantom args =
let argContracts = map getPhantom args
rawNm = rawNameFor name
rawVar = SVar rawNm Nothing
argNames = take (length args) ["x","y","z"]
newArgs = zipWith DefBinder argNames (map Just argContracts)
wrappedBody = foldl SApp rawVar (map (\n -> SVar n Nothing) argNames)
wrapper = wrapArgs newArgs (wrapReturn ret wrappedBody)
in [ SDef name [] (SLet rawNm body wrapper) ]
| otherwise = [ SDef name [] (wrapArgs args body') ]
where
body' = wrapReturn ret body
okCont = SLambda ["r"] (SVar "r" Nothing)
errCont = SLambda ["msg"] (SVar "msg" Nothing)
isPhantom (DefPhantom _) = True
isPhantom _ = False
getPhantom (DefPhantom c) = c
getPhantom _ = error "expected phantom annotation"
wrapReturn Nothing b = b
wrapReturn (Just c) b =
withContractE (viewExprToAst c) b (SLambda ["r"] (SVar "r" Nothing)) errCont
withContractE (viewExprToAst c) b okCont errCont
wrapArgs [] b = b
wrapArgs (DefBinder nm Nothing : rest) b = SLambda [nm] (wrapArgs rest b)
@@ -54,8 +69,6 @@ desugarDefAnn name args ret body = SDef name [] (wrapArgs args body')
wrapArgs (DefPhantom _ : _) _ =
error "phantom contract arguments are not yet supported by the frontend"
errCont = SLambda ["msg"] (SVar "msg" Nothing)
-- | Turn a source annotation expression into an ordinary AST expression.
-- Contract annotations are written with the same surface syntax as terms,
-- so the mapping is mostly structural.

4
src/Lexer.hs
View File

@@ -36,7 +36,6 @@ tricuLexer = do
, try dot
, try identifierWithHash
, try keywordT
, try lExport
, try identifier
, try namespace
, try integerLiteral
@@ -131,9 +130,6 @@ lImport = do
name <- importAlias
return (LImport path name)
lExport :: Lexer LToken
lExport = string "!export" *> notFollowedBy alphaNumChar $> LExport
importAlias :: Lexer String
importAlias = string "!Local" <|> do
first <- letterChar <|> char '_'

1
src/Main.hs
View File

@@ -442,7 +442,6 @@ runImport opts = do
name
(treeTermRef root)
"arboricx.abi.tree.v1"
Nothing
| (name, root) <- roots
]
moduleName = T.pack $ maybe (takeBaseName file) id (importModule opts)

27
src/Module/Manifest.hs
View File

@@ -41,7 +41,6 @@ data ModuleExport = ModuleExport
{ moduleExportName :: Text
, moduleExportObject :: ObjectRef
, moduleExportAbi :: Text
, moduleExportContract :: Maybe ObjectRef
} deriving (Eq, Ord, Show)
manifestDomain :: Domain
@@ -59,17 +58,13 @@ encodeManifest manifest = encodeUtf8 $ Text.unlines $
, esc (objectRefKind $ moduleReferenceRef ref)
, esc (objectRefHash $ moduleReferenceRef ref)
]
encodeExport ex =
let base = Text.intercalate "\t"
[ "export"
, esc (moduleExportName ex)
, esc (objectRefKind $ moduleExportObject ex)
, esc (objectRefHash $ moduleExportObject ex)
, esc (moduleExportAbi ex)
]
in case moduleExportContract ex of
Nothing -> base
Just ref -> base <> "\t" <> esc (objectRefKind ref) <> "\t" <> esc (objectRefHash ref)
encodeExport ex = Text.intercalate "\t"
[ "export"
, esc (moduleExportName ex)
, esc (objectRefKind $ moduleExportObject ex)
, esc (objectRefHash $ moduleExportObject ex)
, esc (moduleExportAbi ex)
]
-- | Parse the canonical manifest encoding.
decodeManifest :: ByteString -> Either String ModuleManifest
@@ -92,14 +87,6 @@ decodeManifest bs = do
<$> unesc name
<*> (ObjectRef <$> unesc kind <*> unesc hash)
<*> unesc abi
<*> pure Nothing
Right manifest { moduleManifestExports = moduleManifestExports manifest ++ [ex] }
["export", name, kind, hash, abi, ckind, chash] -> do
ex <- ModuleExport
<$> unesc name
<*> (ObjectRef <$> unesc kind <*> unesc hash)
<*> unesc abi
<*> (Just <$> (ObjectRef <$> unesc ckind <*> unesc chash))
Right manifest { moduleManifestExports = moduleManifestExports manifest ++ [ex] }
_ -> Left $ "invalid module manifest row: " ++ Text.unpack line

1
src/Module/Resolver.hs
View File

@@ -84,7 +84,6 @@ resolveModuleExport resolver namespace ex = do
, resolvedExportLocalName = nsVariable namespace (T.unpack sourceName)
, resolvedExportObject = ref
, resolvedExportAbi = moduleExportAbi ex
, resolvedExportContract = moduleExportContract ex
, resolvedExportTerm = term
}

16
src/Parser.hs
View File

@@ -69,12 +69,9 @@ manyItemsP = do
topItemP :: TokParser TricuAST
topItemP = do
toks <- getInput
case toks of
LExport : _ -> exportP
_ ->
case definitionHeadTop toks of
Just _ -> definitionP
Nothing -> exprTopP
case definitionHeadTop toks of
Just _ -> definitionP
Nothing -> exprTopP
definitionHeadTop :: [LToken] -> Maybe (String, [String])
definitionHeadTop toks =
@@ -221,13 +218,6 @@ importP = do
isImport (LImport _ _) = True
isImport _ = False
exportP :: TokParser TricuAST
exportP = do
void (tok (== LExport) "export")
name <- identifierNameP
mContract <- optional (tok (== LColon) ":" *> annotationTypeP)
pure (SExport name mContract)
exprTopP :: TokParser TricuAST
exprTopP = do
toks <- getInput

9
src/Research.hs
View File

@@ -19,10 +19,9 @@ import qualified Data.Text as T
data T = Leaf | Stem T | Fork T T
deriving (Show, Eq, Ord)
-- Contract source annotations
-- ViewType, ViewRef, and ViewProvenance were removed with the old View Contract
-- checker. Source annotations are still parsed into ViewExpr but are not
-- interpreted by a separate static checker.
-- Contract source annotations for @ and =@ syntax. ViewExpr carries the
-- surface syntax of a contract until Frontend.ContractDesugar turns it into a
-- runtime contract application.
data ViewExpr
= VEName String
| VEVar String
@@ -61,7 +60,6 @@ data TricuAST
| SLet String TricuAST TricuAST
| SEmpty
| SImport String String
| SExport String (Maybe ViewExpr)
deriving (Show, Eq, Ord)
-- Lexer Tokens
@@ -71,7 +69,6 @@ data LToken
| LKeywordT
| LNamespace String
| LImport String String
| LExport
| LAssign
| LAssignAt
| LAt