Back out the worst of the unsound nonsense

2026-07-10 18:26:38 -05:00
parent 34aee3bf93
commit c6e4a43178
9 changed files with 152 additions and 1297 deletions
--- a/src/Check.hs
+++ b/src/Check.hs
@@ -10,7 +10,7 @@ import Check.Core
 import Check.IO
 import ContentStore (ObjectRef, StorePath, getViewType)
 import Eval (evalTricu)
-import FileEval (LoadedSource(..), defaultStorePath, evaluateFile, evaluateFileWithStore, loadFileWithStore, valueViewFactsFromEnv)
+import FileEval (LoadedSource(..), defaultStorePath, evaluateFile, evaluateFileWithStore, loadFileWithStore)
 import Research (Env, ViewType)

 import qualified Data.Map as Map
@@ -29,8 +29,7 @@ checkFileWithStore store path = do
  let baseEnv = Map.union viewEnv (loadedImports loaded)
      checkerEnv = evalTricu baseEnv (loadedAst loaded)
  imports <- importedViewsFromResolvedModulesEither (loadImportedView store) (loadedModules loaded)
-  valueFacts <- either (errorWithoutStackTrace . ("invalid value-level viewFacts: " ++)) pure (valueViewFactsFromEnv checkerEnv)
-  checkProgramWithEnvAndImportedViews checkerEnv (imports ++ valueFacts) (loadedAst loaded)
+  checkProgramWithEnvAndImportedViews checkerEnv imports (loadedAst loaded)

 viewCheckerEnv :: Env
 viewCheckerEnv = unsafePerformIO (evaluateFile "./lib/view.tri")
--- a/src/Check/Core.hs
+++ b/src/Check/Core.hs
@@ -12,7 +12,6 @@ module Check.Core
  , lowerViewExpr
  ) where

-import Control.Applicative ((<|>))
 import Control.Monad.State.Strict
 import Data.Char (isDigit)
 import Data.Maybe (mapMaybe)
@@ -74,6 +73,11 @@ checkSourceWithEnvAndImportedViews checkerEnv imports source =
  checkProgramWithEnvAndImportedViews checkerEnv imports (parseTricu source)

 checkProgramWithEnvAndImportedViews :: Env -> [ImportedView] -> [TricuAST] -> IO String
+checkProgramWithEnvAndImportedViews _ _ asts
+  | not (any isAnnotatedDefinition asts) = pure "ok"
+  where
+    isAnnotatedDefinition SDefAnn {} = True
+    isAnnotatedDefinition _ = False
 checkProgramWithEnvAndImportedViews checkerEnv imports asts = do
  case lowerProgramWithImportedViewsDebugInEnv checkerEnv imports asts of
    Left err -> pure err
@@ -100,82 +104,6 @@ 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
-  SLet name val body ->
-    definitionUnsafeBaseReason localNames allowedExternalFacts bound val
-      <|> definitionUnsafeBaseReason localNames allowedExternalFacts (Set.insert name bound) 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]
@@ -231,7 +159,6 @@ 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
@@ -289,12 +216,6 @@ 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
@@ -303,7 +224,6 @@ lowerProgramWithImportedViewsDebugInEnv checkerEnvForLowering imports asts = do
        , 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
@@ -332,14 +252,10 @@ lowerAnnotatedProgram defs = do
 lowerDefinitionDeclaration :: TricuAST -> LowerM [String]
 lowerDefinitionDeclaration (SDefAnn name args ret _) = do
  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]
+  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]
@@ -356,17 +272,7 @@ 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)
+canonicalDefinitionViews args ret = (args, ret, declaredDefinitionView args ret)

 declaredDefinitionView :: [DefArg] -> Maybe ViewExpr -> ViewExpr
 declaredDefinitionView args ret =
@@ -376,10 +282,6 @@ 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
@@ -900,8 +802,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
+  VEVar name -> Left $ "polymorphic View variables are unsupported: " ++ show name
+  VEVarId varId -> Left $ "polymorphic View variables are unsupported: " ++ show varId
  VEInt n -> Right (show n)
  VEString s -> Right (show s)
  VEList items -> do
@@ -931,45 +833,10 @@ 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
+  VEForall _ _ -> Left "quantified View contracts are unsupported"
+  VEExists _ _ -> Left "existential View contracts are unsupported"
  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 ++ ")"
--- a/src/FileEval.hs
+++ b/src/FileEval.hs
@@ -14,7 +14,6 @@ module FileEval
  , compileFileWithStore
  , loadFileWithStore
  , loadFileWithStoreMode
-  , valueViewFactsFromEnv
  , defaultStorePath
  ) where

@@ -36,8 +35,6 @@ import Wire (buildBundle, encodeBundle, decodeBundle, verifyBundle, Bundle(..))

 import Data.List       (partition, isPrefixOf)
 import Data.Maybe      (mapMaybe)
-import Control.Monad   (forM)
-import qualified Data.Set as Set
 import System.Directory (getHomeDirectory, getTemporaryDirectory)
 import System.FilePath ((</>))
 import System.Exit (die)
@@ -204,12 +201,9 @@ buildWorkspaceModule ctx store moduleName sourcePath = do
  localViewsResult <- localViews
  resolvedLocalViews <- either (errorWithoutStackTrace . (("Workspace module " ++ show moduleName ++ " has invalid exported View Contract annotation: ") ++)) pure localViewsResult
  importedViews <- importedViewsFromResolvedModulesEither (getViewType store) (loadedModules loaded)
-  valueFacts <- either (errorWithoutStackTrace . (("Workspace module " ++ show moduleName ++ " has invalid value-level viewFacts: ") ++)) pure (valueViewFactsFromEnv env)
-  validateValueViewFactExports moduleName names valueFacts
  let localViewFacts = Map.map (\view -> (view, ViewChecked)) resolvedLocalViews
      importedViewFacts = Map.fromList [(importedViewName iv, (importedViewType iv, importedViewProvenance iv)) | iv <- importedViews]
-      valueViewFacts = Map.fromList [(importedViewName iv, (importedViewType iv, importedViewProvenance iv)) | iv <- valueFacts]
-      exportViewFacts = Map.unions [localViewFacts, valueViewFacts, importedViewFacts]
+      exportViewFacts = Map.union localViewFacts importedViewFacts
  exports <- mapM (buildExport env exportViewFacts) names
  manifestHash <- putManifest store (ModuleManifest [] exports)
  writeAlias store ModuleAlias (T.pack moduleName) (ObjectRef (unDomain manifestDomain) manifestHash)
@@ -237,62 +231,12 @@ enforceWorkspaceModuleContracts store moduleName importEnv modules asts
      viewEnv <- evaluateFileWithContextWithStoreAndMode IgnoreContracts (Just store) Map.empty "./lib/view.tri"
      let checkerEnv = evalTricu (Map.union viewEnv importEnv) asts
      imports <- importedViewsFromResolvedModulesEither (getViewType store) modules
-      valueFacts <- either (errorWithoutStackTrace . (("Workspace module " ++ show moduleName ++ " has invalid value-level viewFacts: ") ++)) pure (valueViewFactsFromEnv checkerEnv)
-      resultText <- checkProgramWithEnvAndImportedViews checkerEnv (imports ++ valueFacts) asts
+      resultText <- checkProgramWithEnvAndImportedViews checkerEnv imports asts
      case resultText of
        "ok" -> pure ()
        diagnostic -> errorWithoutStackTrace $
          "Workspace module " ++ show moduleName ++ " failed View Contract check: " ++ diagnostic

-valueViewFactsFromEnv :: Env -> Either String [ImportedView]
-valueViewFactsFromEnv env = case Map.lookup "viewFacts" env of
-  Nothing -> Right []
-  Just factsTree -> do
-    facts <- context "viewFacts is not a list" (toList factsTree)
-    decoded <- forM (zip [0 :: Int ..] facts) (uncurry decodeFactAt)
-    rejectDuplicateFacts decoded
-    pure decoded
-  where
-    decodeFactAt index factTree = do
-      (nameTree, rest) <- context prefix (pairParts factTree)
-      name <- context (prefix ++ ": export name is not a string") (toString nameTree)
-      (provenanceTree, viewTree) <- context (prefixFor name ++ ": payload is not a pair") (pairParts rest)
-      provenance <- context (prefixFor name ++ ": invalid provenance") (decodeProvenance provenanceTree)
-      view <- context (prefixFor name ++ ": malformed View") (treeToViewType viewTree)
-      pure (ImportedView name view provenance)
-      where
-        prefix = "viewFacts[" ++ show index ++ "]"
-        prefixFor name = prefix ++ " for " ++ show name
-
-    pairParts (Fork left right) = Right (left, right)
-    pairParts _ = Left "expected pair"
-
-    decodeProvenance tree = do
-      n <- toNumber tree
-      case n of
-        0 -> Right ViewChecked
-        1 -> Right ViewTrusted
-        2 -> Right ViewUnchecked
-        _ -> Left $ "unknown provenance tag " ++ show n
-
-    rejectDuplicateFacts facts = go Set.empty facts
-      where
-        go _ [] = Right ()
-        go seen (fact : rest)
-          | importedViewName fact `Set.member` seen = Left $ "duplicate viewFacts entry for " ++ show (importedViewName fact)
-          | otherwise = go (Set.insert (importedViewName fact) seen) rest
-
-    context label = either (Left . ((label ++ ": ") ++)) Right
-
-validateValueViewFactExports :: String -> [String] -> [ImportedView] -> IO ()
-validateValueViewFactExports moduleName exportedNames facts = do
-  let exported = Set.fromList exportedNames
-      missing = [importedViewName fact | fact <- facts, importedViewName fact `Set.notMember` exported]
-  case missing of
-    [] -> pure ()
-    name : _ -> errorWithoutStackTrace $
-      "Workspace module " ++ show moduleName ++ " has value-level viewFacts for non-exported name " ++ show name
-
 isAnnotatedDefinition :: TricuAST -> Bool
 isAnnotatedDefinition SDefAnn {} = True
 isAnnotatedDefinition _ = False
@@ -300,13 +244,10 @@ isAnnotatedDefinition _ = False
 topLevelDefinitions :: [TricuAST] -> [String]
 topLevelDefinitions = mapMaybe go
  where
-    go (SDef name _ _) | not (isViewFactMetadataName name) = Just name
-    go (SDefAnn name _ _ _) | not (isViewFactMetadataName name) = Just name
+    go (SDef name _ _) = Just name
+    go (SDefAnn name _ _ _) = Just name
    go _ = Nothing

-isViewFactMetadataName :: String -> Bool
-isViewFactMetadataName name = name == "viewFacts"
-
 topLevelDefinitionViews :: [TricuAST] -> Map.Map String ViewExpr
 topLevelDefinitionViews asts = Map.fromList (mapMaybe go asts)
  where
@@ -328,7 +269,7 @@ resolveViewExpression checkerEnv view = do
    Left err -> Left $ "could not validate view expression " ++ show expr ++ ": " ++ err

 definitionView :: [DefArg] -> Maybe ViewExpr -> ViewExpr
-definitionView args resultView = quantifyFreeViewVars $
+definitionView args resultView =
  case argViews of
    [] -> finalView
    _  -> VEApp (VEApp (VEName "Fn") (VEList argViews)) finalView
@@ -336,34 +277,6 @@ definitionView args resultView = quantifyFreeViewVars $
    argViews = map defArgView args
    finalView = maybe exportedViewAny id resultView

-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
-
 defArgView :: DefArg -> ViewExpr
 defArgView (DefBinder _ Nothing) = exportedViewAny
 defArgView (DefBinder _ (Just ty)) = ty