Back out the worst of the unsound nonsense
This commit is contained in:
@@ -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 ++ ")"
|
||||
|
||||
Reference in New Issue
Block a user