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

Useful but limited polymorphism

Browse Source
This commit is contained in:
James Eversole
2026-05-25 17:54:04 -05:00
parent fdebb6c13d
commit 84714925f1
17 changed files with 1778 additions and 122 deletions
Download Patch File Download Diff File Expand all files Collapse all files

256
src/Check/Core.hs
View File

@@ -12,9 +12,12 @@ module Check.Core
, lowerViewExpr
) where
import Control.Applicative ((<|>))
import Control.Monad.State.Strict
import Data.Char (isDigit)
import Data.Maybe (mapMaybe)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import ContentStore.Alias (ObjectRef(..))
@@ -27,8 +30,9 @@ import Parser (parseTricu)
import Research
data ImportedView = ImportedView
{ importedViewName :: String
, importedViewType :: ViewType
{ importedViewName :: String
, importedViewType :: ViewType
, importedViewProvenance :: ViewProvenance
} deriving (Show, Eq)
-- Convert module-resolution metadata into checker evidence inputs. The loader
@@ -57,7 +61,7 @@ importedViewsFromResolvedModulesEither loadView modules = concat <$> mapM fromMo
++ show (resolvedExportLocalName ex)
++ " (kind " ++ showRefKind ref ++ ", hash " ++ showRefHash ref ++ "): "
++ err
Right view -> pure [ImportedView (resolvedExportLocalName ex) view]
Right view -> pure [ImportedView (resolvedExportLocalName ex) view (maybe ViewUnchecked id (resolvedExportProvenance ex))]
showRefKind = T.unpack . objectRefKind
showRefHash = T.unpack . objectRefHash
@@ -96,6 +100,102 @@ annotateDiagnostic debugNames message =
"symbol " ++ symText ++ " (" ++ label ++ ") " ++ unwords rest
_ -> message
viewExprHasParametricBinder :: ViewExpr -> Bool
viewExprHasParametricBinder expr = case expr of
VEVar _ -> True
VEVarId _ -> True
VEList items -> any viewExprHasParametricBinder items
VEApp fn arg -> viewExprHasParametricBinder fn || viewExprHasParametricBinder arg
VEForall binders body -> not (null binders) || viewExprHasParametricBinder body
VEExists binders body -> not (null binders) || viewExprHasParametricBinder body
VEName _ -> False
VEInt _ -> False
VEString _ -> False
VERaw _ -> False
rawTaintedDefinitions :: Set.Set String -> [TricuAST] -> Map.Map String String
rawTaintedDefinitions allowedExternalFacts asts = fixedPoint initiallyRaw
where
allowedFacts = allowedExternalFacts
definitions = Map.fromList
[ (name, (args, body))
| ast <- asts
, Just (name, args, body) <- [definitionBody ast]
]
localNames = Map.keysSet definitions
initiallyRaw = Map.mapMaybeWithKey
(\name (args, body) ->
if name `Set.member` allowedFacts
then Nothing
else definitionUnsafeBaseReason localNames allowedFacts (Set.fromList args) body)
definitions
fixedPoint tainted =
let tainted' = Map.mapMaybeWithKey (transitiveReason tainted) definitions
combined = Map.union tainted tainted'
in if combined == tainted then tainted else fixedPoint combined
transitiveReason tainted name (args, body)
| name `Map.member` tainted = Nothing
| name `Set.member` allowedFacts = Nothing
| otherwise = case filter (`Map.member` tainted) (astFreeRefs (foldr Set.delete localNames args) body) of
helper : _ -> Just $ "depends on raw-tainted local helper " ++ show helper ++ " (" ++ tainted Map.! helper ++ ")"
[] -> Nothing
definitionBody ast = case ast of
SDef name args body -> Just (name, args, body)
SDefAnn name args _ body -> Just (name, defArgNames args, body)
_ -> Nothing
definitionUnsafeBaseReason :: Set.Set String -> Set.Set String -> Set.Set String -> TricuAST -> Maybe String
definitionUnsafeBaseReason localNames allowedExternalFacts bound ast = case ast of
SVar name _
| name `Set.member` bound -> Nothing
| name `Set.member` localNames -> Nothing
| name `Set.member` allowedExternalFacts -> Nothing
| name == "triage" -> Just "uses raw triage directly"
| otherwise -> Just $ "depends on unchecked or unknown external name " ++ show name
SInt _ -> Nothing
SStr _ -> Nothing
SList items -> firstJust (map (definitionUnsafeBaseReason localNames allowedExternalFacts bound) items)
SDef _ args body -> definitionUnsafeBaseReason localNames allowedExternalFacts (foldr Set.insert bound args) body
SDefAnn _ args _ body -> definitionUnsafeBaseReason localNames allowedExternalFacts (foldr Set.insert bound (defArgNames args)) body
SApp fn arg -> definitionUnsafeBaseReason localNames allowedExternalFacts bound fn <|> definitionUnsafeBaseReason localNames allowedExternalFacts bound arg
TLeaf -> Just "uses raw t directly"
TStem _ -> Just "uses raw t directly"
TFork _ _ -> Just "uses raw t directly"
SLambda args body -> definitionUnsafeBaseReason localNames allowedExternalFacts (foldr Set.insert bound args) body
SEmpty -> Nothing
SImport _ _ -> Nothing
firstJust :: [Maybe a] -> Maybe a
firstJust [] = Nothing
firstJust (Just x : _) = Just x
firstJust (Nothing : xs) = firstJust xs
astFreeRefs :: Set.Set String -> TricuAST -> [String]
astFreeRefs candidates ast = case ast of
SVar name _ | name `Set.member` candidates -> [name]
SVar _ _ -> []
SInt _ -> []
SStr _ -> []
SList items -> concatMap (astFreeRefs candidates) items
SDef _ args body -> astFreeRefs (foldr Set.delete candidates args) body
SDefAnn _ args _ body -> astFreeRefs (foldr Set.delete candidates (defArgNames args)) body
SApp fn arg -> astFreeRefs candidates fn ++ astFreeRefs candidates arg
TLeaf -> []
TStem inner -> astFreeRefs candidates inner
TFork left right -> astFreeRefs candidates left ++ astFreeRefs candidates right
SLambda args body -> astFreeRefs (foldr Set.delete candidates args) body
SEmpty -> []
SImport _ _ -> []
defArgNames :: [DefArg] -> [String]
defArgNames = mapMaybe defArgName
where
defArgName (DefBinder name _) = Just name
defArgName (DefPhantom _) = Nothing
lowerSource :: String -> Either String String
lowerSource = lowerProgram . parseTricu
@@ -127,6 +227,7 @@ data LowerState = LowerState
, knownNodeViews :: Map.Map Integer ViewExpr
, nodePayloads :: Map.Map Integer T
, debugNames :: Map.Map Integer String
, rawTaintedDefs :: Map.Map String String
}
type LowerM a = StateT LowerState (Either String) a
@@ -149,18 +250,29 @@ lowerProgramWithImportedViewsDebugInEnv checkerEnvForLowering imports asts = do
topNames = map definitionName definitions
tops = Map.fromList (zip topNames [0..])
topCount = Map.size tops
importCandidates = Set.fromList (map importedViewName imports) `Set.difference` Set.fromList topNames
usedImportNames = Set.fromList (concatMap (astFreeRefs importCandidates) asts)
activeImports = filter (\imported -> importedViewName imported `Set.member` usedImportNames) imports
importedSyms = Map.fromList
[ (importedViewName imported, fromIntegral (topCount + idx))
| (idx, imported) <- zip [0..] imports
| (idx, imported) <- zip [0..] activeImports
]
topDebug = Map.fromList [ (sym, name) | (name, sym) <- Map.toList tops ]
importDebug = Map.fromList
[ (sym, "imported " ++ name)
| (name, sym) <- Map.toList importedSyms
]
localFactByName = Map.fromList [(importedViewName imported, imported) | imported <- imports, importedViewName imported `elem` topNames]
trustedLocalFacts =
[ (sym, viewTypeToExpr (importedViewType imported), importedViewProvenance imported)
| (name, sym) <- Map.toList tops
, Just imported <- [Map.lookup name localFactByName]
, importedViewProvenance imported `elem` [ViewChecked, ViewTrusted]
]
trustedLocalKnown = Map.fromList [(sym, view) | (sym, view, _) <- trustedLocalFacts]
importKnown = Map.fromList
[ (sym, viewTypeToExpr (importedViewType imported))
| imported <- imports
| imported <- activeImports
, Just sym <- [Map.lookup (importedViewName imported) importedSyms]
]
payloads = Map.fromList $
@@ -173,31 +285,39 @@ lowerProgramWithImportedViewsDebugInEnv checkerEnvForLowering imports asts = do
, Just term <- [Map.lookup name checkerEnvForLowering]
]
annotated = [ def | def@SDefAnn {} <- asts ]
allowedExternalFacts = Set.fromList
[ importedViewName imported
| imported <- imports
, importedViewProvenance imported `elem` [ViewChecked, ViewTrusted]
]
taintedDefs = rawTaintedDefinitions allowedExternalFacts asts
initialState = LowerState
{ nextSym = fromIntegral (Map.size tops + Map.size importedSyms)
, topSyms = tops
, scopes = []
, externSyms = importedSyms
, knownNodeViews = importKnown
, knownNodeViews = Map.union trustedLocalKnown importKnown
, nodePayloads = payloads
, debugNames = Map.union topDebug importDebug
, rawTaintedDefs = taintedDefs
}
(localNodes, finalState) <- runStateT (lowerAnnotatedProgram annotated) initialState
trustedLocalNodes <- mapM (lowerImportedView (nodePayloads finalState)) trustedLocalFacts
importNodes <- mapM (lowerImportedView (nodePayloads finalState))
[ (sym, viewTypeToExpr (importedViewType imported))
| imported <- imports
[ (sym, viewTypeToExpr (importedViewType imported), importedViewProvenance imported)
| imported <- activeImports
, Just sym <- [Map.lookup (importedViewName imported) importedSyms]
]
let nodes = importNodes ++ localNodes
let nodes = trustedLocalNodes ++ 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
lowerImportedView :: Map.Map Integer T -> (Integer, ViewExpr, ViewProvenance) -> Either String String
lowerImportedView payloadsBySym (sym, view, provenance) = do
viewExpr <- lowerViewExpr view
let payload = maybe "t" treeSource (Map.lookup sym payloadsBySym)
pure $ "typedValue " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload
pure $ "typedValueWithProvenance " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload ++ " " ++ viewProvenanceSource provenance
lowerAnnotatedProgram :: [TricuAST] -> LowerM [String]
lowerAnnotatedProgram defs = do
@@ -207,19 +327,23 @@ lowerAnnotatedProgram defs = do
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]
let (_, _, declaredView) = canonicalDefinitionViews args ret
tainted <- gets rawTaintedDefs
if viewExprHasParametricBinder declaredView && name `Map.member` tainted
then liftEither (Left $ "parametric View definition " ++ show name ++ " depends on raw intensional Tree Calculus machinery (" ++ tainted Map.! name ++ "); use a trusted eliminator boundary instead")
else do
sym <- symbolForTop name
recordKnown sym declaredView
node <- typedValueNode sym declaredView
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
let (flowArgs, flowRet, _) = canonicalDefinitionViews args ret
binderNodes <- concat <$> mapM lowerBinderDeclaration flowArgs
let phantomViews = map lowerPhantomArgType (phantomArgs flowArgs)
(returnArgs, returnResult) <- lowerReturnObligation flowRet
bodyNodes <- lowerBodyWithPhantoms (phantomViews ++ returnArgs) returnResult body
pure (binderNodes ++ bodyNodes)
lowerDefinitionFlow _ = liftEither (Left "internal check error: expected annotated definition")
@@ -227,6 +351,19 @@ lowerDefinitionFlow _ = liftEither (Left "internal check error: expected annotat
viewAnyType :: ViewExpr
viewAnyType = VEName "Any"
canonicalDefinitionViews :: [DefArg] -> Maybe ViewExpr -> ([DefArg], Maybe ViewExpr, ViewExpr)
canonicalDefinitionViews args ret =
let rawView = declaredDefinitionView args ret
vars = Set.toList (freeViewVars rawView)
binderIds = zip vars [0..]
binderMap = Map.fromList binderIds
mappedArgs = map (mapDefArgView (rewriteViewVars binderMap)) args
mappedRet = fmap (rewriteViewVars binderMap) ret
mappedView = declaredDefinitionView mappedArgs mappedRet
binders = map snd binderIds
declaredView = if null vars then mappedView else VEForall binders mappedView
in (mappedArgs, mappedRet, declaredView)
declaredDefinitionView :: [DefArg] -> Maybe ViewExpr -> ViewExpr
declaredDefinitionView args ret =
case map argType args of
@@ -235,6 +372,10 @@ declaredDefinitionView args ret =
where
resultType = maybe viewAnyType id ret
mapDefArgView :: (ViewExpr -> ViewExpr) -> DefArg -> DefArg
mapDefArgView f (DefBinder name mTy) = DefBinder name (fmap f mTy)
mapDefArgView f (DefPhantom ty) = DefPhantom (f ty)
argType :: DefArg -> ViewExpr
argType (DefBinder _ Nothing) = viewAnyType
argType (DefBinder _ (Just ty)) = ty
@@ -249,10 +390,13 @@ emitDeclaration sym views retExpr = do
pure $ "typedValue " ++ show sym ++ " (viewFn [" ++ unwords (map parens views) ++ "] " ++ parens retExpr ++ ") " ++ payload
typedValueNode :: Integer -> ViewExpr -> LowerM String
typedValueNode sym view = do
typedValueNode sym view = typedValueNodeWithProvenance sym view ViewChecked
typedValueNodeWithProvenance :: Integer -> ViewExpr -> ViewProvenance -> LowerM String
typedValueNodeWithProvenance sym view provenance = do
viewExpr <- liftEither (lowerViewExpr view)
payload <- payloadSourceFor sym
pure ("typedValue " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload)
pure ("typedValueWithProvenance " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload ++ " " ++ viewProvenanceSource provenance)
typedRequireNode :: Integer -> ViewExpr -> LowerM String
typedRequireNode sym view = do
@@ -260,6 +404,11 @@ typedRequireNode sym view = do
payload <- payloadSourceFor sym
pure ("typedRequire " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload)
viewProvenanceSource :: ViewProvenance -> String
viewProvenanceSource ViewChecked = "viewProvenanceChecked"
viewProvenanceSource ViewTrusted = "viewProvenanceTrusted"
viewProvenanceSource ViewUnchecked = "viewProvenanceUnchecked"
declareKnown :: Integer -> ViewExpr -> LowerM String
declareKnown sym view = do
recordKnown sym view
@@ -553,11 +702,23 @@ lowerListLiteral items = do
lowerApplicationArgument :: Maybe ViewExpr -> TricuAST -> LowerM (Integer, [String], Maybe ViewExpr)
lowerApplicationArgument (Just fnView) arg =
case viewExprFnParts fnView of
Just (argView : _, _) -> lowerExprKnownAgainst arg argView
Just (argView : _, _)
| containsViewVar argView -> lowerExprKnown arg
| otherwise -> lowerExprKnownAgainst arg argView
_ -> lowerExprKnown arg
lowerApplicationArgument _ arg =
lowerExprKnown arg
containsViewVar :: ViewExpr -> Bool
containsViewVar view = case view of
VEVar _ -> True
VEVarId _ -> True
VEList items -> any containsViewVar items
VEApp f a -> containsViewVar f || containsViewVar a
VEForall _ body -> containsViewVar body
VEExists _ body -> containsViewVar body
_ -> False
applicationDebugLabel :: TricuAST -> String
applicationDebugLabel func =
case applicationHeadName func of
@@ -672,6 +833,7 @@ lowerArgView (DefPhantom ty) = liftEither (lowerViewExpr ty)
viewTypeToExpr :: ViewType -> ViewExpr
viewTypeToExpr view = case view of
VTName name -> VEName name
VTVar varId -> VEVarId varId
VTRef n -> VEApp (VEName "Ref") (VEInt n)
VTRefText s -> VEApp (VEName "Ref") (VEString s)
VTList item -> VEApp (VEName "List") (viewTypeToExpr item)
@@ -679,6 +841,8 @@ viewTypeToExpr view = case view of
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))
VTForall binders body -> VEForall binders (viewTypeToExpr body)
VTExists binders body -> VEExists binders (viewTypeToExpr body)
VTFn args resultView -> viewExprFn (map viewTypeToExpr args) (viewTypeToExpr resultView)
viewExprFn :: [ViewExpr] -> ViewExpr -> ViewExpr
@@ -688,12 +852,15 @@ viewExprList :: ViewExpr -> ViewExpr
viewExprList = VEApp (VEName "List")
viewExprFnParts :: ViewExpr -> Maybe ([ViewExpr], ViewExpr)
viewExprFnParts (VEForall _ body) = viewExprFnParts body
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)
VEVar _ -> Nothing
VEVarId varId -> Just (VTVar varId)
VEApp (VEName "Ref") (VEInt n) -> Just (VTRef n)
VEApp (VEName "Ref") (VEString s) -> Just (VTRefText s)
VEApp (VEName "List") item -> VTList <$> viewExprAsType item
@@ -701,6 +868,8 @@ viewExprAsType view = case view of
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
VEForall binders body -> VTForall binders <$> viewExprAsType body
VEExists binders body -> VTExists binders <$> viewExprAsType body
_ -> Nothing
lowerViewExpr :: ViewExpr -> Either String String
@@ -711,6 +880,8 @@ lowerViewExpr ty = case ty of
VEName "Byte" -> Right "viewByte"
VEName "Unit" -> Right "viewUnit"
VEName name -> Right name
VEVar name -> Right $ "viewVar " ++ show name
VEVarId varId -> Right $ "viewVar " ++ show varId
VEInt n -> Right (show n)
VEString s -> Right (show s)
VEList items -> do
@@ -740,8 +911,45 @@ lowerViewExpr ty = case ty of
f <- lowerViewExpr func
a <- lowerViewExpr arg
Right $ parens f ++ " " ++ parens a
VEForall binders body -> do
bodyExpr <- lowerViewExpr body
Right $ "viewForall " ++ lowerStringList binders ++ " " ++ parens bodyExpr
VEExists binders body -> do
bodyExpr <- lowerViewExpr body
Right $ "viewExists " ++ lowerStringList binders ++ " " ++ parens bodyExpr
VERaw raw -> Right raw
lowerStringList :: [Integer] -> String
lowerStringList items = "[" ++ unwords (map (parens . show) items) ++ "]"
quantifyFreeViewVars :: ViewExpr -> ViewExpr
quantifyFreeViewVars view =
let vars = Set.toList (freeViewVars view)
binderIds = zip vars [0..]
binderMap = Map.fromList binderIds
body = rewriteViewVars binderMap view
binders = map snd binderIds
in if null vars then view else VEForall binders body
rewriteViewVars :: Map.Map String Integer -> ViewExpr -> ViewExpr
rewriteViewVars binderMap view = case view of
VEVar name -> maybe (VEVar name) VEVarId (Map.lookup name binderMap)
VEList items -> VEList (map (rewriteViewVars binderMap) items)
VEApp f a -> VEApp (rewriteViewVars binderMap f) (rewriteViewVars binderMap a)
VEForall binders body -> VEForall binders (rewriteViewVars binderMap body)
VEExists binders body -> VEExists binders (rewriteViewVars binderMap body)
_ -> view
freeViewVars :: ViewExpr -> Set.Set String
freeViewVars view = case view of
VEVar name -> Set.singleton name
VEVarId _ -> Set.empty
VEList items -> Set.unions (map freeViewVars items)
VEApp f a -> Set.union (freeViewVars f) (freeViewVars a)
VEForall _ body -> freeViewVars body
VEExists _ body -> freeViewVars body
_ -> Set.empty
treeSource :: T -> String
treeSource Leaf = "t"
treeSource (Stem x) = "(t " ++ treeSource x ++ ")"