Begin removing view related code and docs
This commit is contained in:
42
src/Check.hs
42
src/Check.hs
@@ -1,42 +0,0 @@
|
||||
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
|
||||
@@ -1,846 +0,0 @@
|
||||
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 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(..))
|
||||
import Eval (evalTricu, result)
|
||||
import Module.Resolver
|
||||
( ResolvedExport(..)
|
||||
, ResolvedModule(..)
|
||||
)
|
||||
import Parser (parseTricu)
|
||||
import Research
|
||||
|
||||
data ImportedView = ImportedView
|
||||
{ importedViewName :: String
|
||||
, importedViewType :: ViewType
|
||||
, importedViewProvenance :: ViewProvenance
|
||||
} 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 (maybe ViewUnchecked id (resolvedExportProvenance ex))]
|
||||
|
||||
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 _ _ 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
|
||||
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
|
||||
|
||||
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
|
||||
SLet name val body -> astFreeRefs candidates val ++ astFreeRefs (Set.delete name candidates) 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
|
||||
|
||||
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
|
||||
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..] 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 <- activeImports
|
||||
, 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 = Map.union trustedLocalKnown importKnown
|
||||
, nodePayloads = payloads
|
||||
, debugNames = Map.union topDebug importDebug
|
||||
}
|
||||
(localNodes, finalState) <- runStateT (lowerAnnotatedProgram annotated) initialState
|
||||
trustedLocalNodes <- mapM (lowerImportedView (nodePayloads finalState)) trustedLocalFacts
|
||||
importNodes <- mapM (lowerImportedView (nodePayloads finalState))
|
||||
[ (sym, viewTypeToExpr (importedViewType imported), importedViewProvenance imported)
|
||||
| imported <- activeImports
|
||||
, Just sym <- [Map.lookup (importedViewName imported) importedSyms]
|
||||
]
|
||||
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, ViewProvenance) -> Either String String
|
||||
lowerImportedView payloadsBySym (sym, view, provenance) = do
|
||||
viewExpr <- lowerViewExpr view
|
||||
let payload = maybe "t" treeSource (Map.lookup sym payloadsBySym)
|
||||
pure $ "typedValueWithProvenance " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload ++ " " ++ viewProvenanceSource provenance
|
||||
|
||||
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
|
||||
let (_, _, declaredView) = canonicalDefinitionViews args ret
|
||||
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
|
||||
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")
|
||||
|
||||
viewAnyType :: ViewExpr
|
||||
viewAnyType = VEName "Any"
|
||||
|
||||
canonicalDefinitionViews :: [DefArg] -> Maybe ViewExpr -> ([DefArg], Maybe ViewExpr, ViewExpr)
|
||||
canonicalDefinitionViews args ret = (args, ret, declaredDefinitionView args ret)
|
||||
|
||||
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 = typedValueNodeWithProvenance sym view ViewChecked
|
||||
|
||||
typedValueNodeWithProvenance :: Integer -> ViewExpr -> ViewProvenance -> LowerM String
|
||||
typedValueNodeWithProvenance sym view provenance = do
|
||||
viewExpr <- liftEither (lowerViewExpr view)
|
||||
payload <- payloadSourceFor sym
|
||||
pure ("typedValueWithProvenance " ++ show sym ++ " " ++ parens viewExpr ++ " " ++ payload ++ " " ++ viewProvenanceSource provenance)
|
||||
|
||||
typedRequireNode :: Integer -> ViewExpr -> LowerM String
|
||||
typedRequireNode sym view = do
|
||||
viewExpr <- liftEither (lowerViewExpr view)
|
||||
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
|
||||
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
|
||||
(SLet name value body, _) -> do
|
||||
(valueSym, valueNodes, _) <- lowerExprKnown value
|
||||
recordDebugName valueSym name
|
||||
bodyResult <- withLocalAlias name valueSym (lowerExprKnownAgainst body expected)
|
||||
let (bodySym, bodyNodes, bodyKnown) = bodyResult
|
||||
pure (bodySym, valueNodes ++ bodyNodes, bodyKnown)
|
||||
-- Hand-written immediately-applied lambda (not compiler output; let/where
|
||||
-- now emit SLet). Kept for source that relies on alias semantics.
|
||||
(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 (SLet name value body) = do
|
||||
(valueSym, valueNodes, _) <- lowerExprKnown value
|
||||
recordDebugName valueSym name
|
||||
bodyResult <- withLocalAlias name valueSym (lowerExprKnown body)
|
||||
let (bodySym, bodyNodes, bodyKnown) = bodyResult
|
||||
pure (bodySym, valueNodes ++ bodyNodes, bodyKnown)
|
||||
-- Hand-written immediately-applied lambda (not compiler output; let/where
|
||||
-- now emit SLet). Kept for source that relies on alias semantics.
|
||||
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 : _, _)
|
||||
| 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
|
||||
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
|
||||
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)
|
||||
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))
|
||||
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
|
||||
viewExprFn args resultView = VEApp (VEApp (VEName "Fn") (VEList args)) resultView
|
||||
|
||||
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
|
||||
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
|
||||
VEForall binders body -> VTForall binders <$> viewExprAsType body
|
||||
VEExists binders body -> VTExists binders <$> viewExprAsType body
|
||||
_ -> 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
|
||||
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
|
||||
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
|
||||
VEForall _ _ -> Left "quantified View contracts are unsupported"
|
||||
VEExists _ _ -> Left "existential View contracts are unsupported"
|
||||
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 ++ ")"
|
||||
422
src/Check/IO.hs
422
src/Check/IO.hs
@@ -1,422 +0,0 @@
|
||||
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 (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 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
|
||||
VEForall binders body -> VTForall binders <$> viewExprAsType body
|
||||
VEExists binders body -> VTExists binders <$> viewExprAsType body
|
||||
_ -> Nothing
|
||||
|
||||
viewTypeToExpr :: ViewType -> ViewExpr
|
||||
viewTypeToExpr view = case view of
|
||||
VTName name -> VEName name
|
||||
VTVar varId -> VEVarId varId
|
||||
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))
|
||||
VTForall binders body -> VEForall binders (viewTypeToExpr body)
|
||||
VTExists binders body -> VEExists binders (viewTypeToExpr body)
|
||||
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
|
||||
SLet name val body -> SLet name <$> transformExpr val <*> 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
|
||||
SLet name val body -> SLet name <$> transformIOAction val <*> 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
|
||||
SLet _ val body -> mentionsContractedName contracts val || 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)
|
||||
SLet name val body -> SLet name (substAst subst val) (substAst (Map.delete name subst) 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)
|
||||
SLet name val body -> parens ("let " ++ name ++ " = " ++ astSource val ++ " in " ++ 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 ++ ")"
|
||||
@@ -4,8 +4,6 @@ module ContentStore
|
||||
, module ContentStore.Arboricx
|
||||
, module ContentStore.Alias
|
||||
, module ContentStore.Resolver
|
||||
, module ContentStore.ViewTree
|
||||
, module ContentStore.ViewContract
|
||||
) where
|
||||
|
||||
import ContentStore.Arboricx
|
||||
@@ -13,5 +11,3 @@ import ContentStore.Alias
|
||||
import ContentStore.Filesystem
|
||||
import ContentStore.Object
|
||||
import ContentStore.Resolver
|
||||
import ContentStore.ViewTree
|
||||
import ContentStore.ViewContract
|
||||
|
||||
@@ -1,265 +0,0 @@
|
||||
{-# 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 (VTVar varId) = BS.cons 0x08 (putU32 (fromIntegral varId))
|
||||
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 (VTForall binders body) = BS.cons 0x09 (putIntegerList binders <> go body)
|
||||
go (VTExists binders body) = BS.cons 0x0a (putIntegerList binders <> go body)
|
||||
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)
|
||||
VTVar varId -> record 8 [field 10 (ofNumber varId)]
|
||||
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]
|
||||
VTForall binders body -> record 9 [field 11 (ofList (map ofNumber binders)), field 12 (viewTypeToTree body)]
|
||||
VTExists binders body -> record 10 [field 11 (ofList (map ofNumber binders)), field 12 (viewTypeToTree body)]
|
||||
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
|
||||
8 -> VTVar <$> (fieldValueAt 10 fields >>= toNumber)
|
||||
9 -> VTForall <$> (fieldValueAt 11 fields >>= integerListFromTree) <*> (fieldValueAt 12 fields >>= treeToViewType)
|
||||
10 -> VTExists <$> (fieldValueAt 11 fields >>= integerListFromTree) <*> (fieldValueAt 12 fields >>= treeToViewType)
|
||||
_ -> 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"
|
||||
|
||||
integerListFromTree tree = toList tree >>= mapM toNumber
|
||||
|
||||
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)
|
||||
0x08 -> do
|
||||
(varId, afterVarId) <- getU32 rest
|
||||
pure (VTVar (fromIntegral varId), afterVarId)
|
||||
0x09 -> do
|
||||
(binders, afterBinders) <- getIntegerList rest
|
||||
(body, afterBody) <- getViewTypeBytes afterBinders
|
||||
pure (VTForall binders body, afterBody)
|
||||
0x0a -> do
|
||||
(binders, afterBinders) <- getIntegerList rest
|
||||
(body, afterBody) <- getViewTypeBytes afterBinders
|
||||
pure (VTExists binders body, afterBody)
|
||||
_ -> 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)
|
||||
|
||||
putIntegerList :: [Integer] -> BS.ByteString
|
||||
putIntegerList items = putU32 (length items) <> mconcat (map (putU32 . fromIntegral) items)
|
||||
|
||||
getIntegerList :: BS.ByteString -> Either String ([Integer], BS.ByteString)
|
||||
getIntegerList bs = do
|
||||
(count, afterCount) <- getU32 bs
|
||||
go count afterCount []
|
||||
where
|
||||
go 0 rest acc = Right (reverse acc, rest)
|
||||
go n rest acc = do
|
||||
(varId, afterVarId) <- getU32 rest
|
||||
go (n - 1) afterVarId (fromIntegral varId : 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
|
||||
@@ -1,192 +0,0 @@
|
||||
module ContentStore.ViewTree
|
||||
( viewTreeKind
|
||||
, viewTreeDomain
|
||||
, encodeViewTree
|
||||
, decodeViewTree
|
||||
, singletonViewTree
|
||||
, singletonViewTreeWithProvenance
|
||||
, viewTreeRootTerm
|
||||
, viewTreeRootViewFact
|
||||
, 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 (treeToViewType, viewTypeToTree)
|
||||
import Research (T(..), ViewProvenance(..), 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 = singletonViewTreeWithProvenance (fmap (\view -> (view, ViewUnchecked)) mView) term
|
||||
|
||||
singletonViewTreeWithProvenance :: Maybe (ViewType, ViewProvenance) -> T -> T
|
||||
singletonViewTreeWithProvenance mViewFact term =
|
||||
record typedProgramTag
|
||||
[ field typedProgramFieldRoot (ofNumber 0)
|
||||
, field typedProgramFieldNodes (ofList [typedValueNode 0 (maybe viewAnyTree (viewTypeToTree . fst) mViewFact) term (fmap snd mViewFact)])
|
||||
]
|
||||
|
||||
-- | 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
|
||||
|
||||
viewTreeRootViewFact :: T -> Either String (Maybe (ViewType, ViewProvenance))
|
||||
viewTreeRootViewFact 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 nodeViewFact node
|
||||
else lookupRoot root rest
|
||||
|
||||
nodeViewFact node = do
|
||||
tag <- recordTag node
|
||||
case tag of
|
||||
21 -> do
|
||||
view <- fieldValue typedNodeFieldView node >>= treeToViewType
|
||||
provenance <- maybe (Right ViewUnchecked) treeToViewProvenance (fieldValueMaybe typedNodeFieldProvenance node)
|
||||
Right (Just (view, provenance))
|
||||
23 -> do
|
||||
view <- fieldValue typedNodeFieldView node >>= treeToViewType
|
||||
provenance <- maybe (Right ViewUnchecked) treeToViewProvenance (fieldValueMaybe typedNodeFieldProvenance node)
|
||||
Right (Just (view, provenance))
|
||||
22 -> Right Nothing
|
||||
_ -> 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 -> Maybe ViewProvenance -> T
|
||||
typedValueNode sym view term mProvenance =
|
||||
record typedNodeTagValue $
|
||||
[ field typedNodeFieldSymbol (ofNumber sym)
|
||||
, field typedNodeFieldView view
|
||||
, field typedNodeFieldTerm term
|
||||
] ++ maybe [] (\provenance -> [field typedNodeFieldProvenance (viewProvenanceToTree provenance)]) mProvenance
|
||||
|
||||
viewProvenanceToTree :: ViewProvenance -> T
|
||||
viewProvenanceToTree ViewChecked = ofNumber 0
|
||||
viewProvenanceToTree ViewTrusted = ofNumber 1
|
||||
viewProvenanceToTree ViewUnchecked = ofNumber 2
|
||||
|
||||
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
|
||||
|
||||
fieldValueMaybe :: Integer -> T -> Maybe T
|
||||
fieldValueMaybe expected recordTree = do
|
||||
fields <- either (const Nothing) Just (recordFields recordTree)
|
||||
values <- either (const Nothing) Just (mapM fieldParts fields)
|
||||
lookup expected values
|
||||
|
||||
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, typedNodeFieldProvenance :: Integer
|
||||
typedNodeTagValue = 21
|
||||
typedNodeFieldSymbol = 0
|
||||
typedNodeFieldView = 1
|
||||
typedNodeFieldTerm = 2
|
||||
typedNodeFieldProvenance = 5
|
||||
|
||||
treeToViewProvenance :: T -> Either String ViewProvenance
|
||||
treeToViewProvenance tree = do
|
||||
tag <- toNumber tree
|
||||
case tag of
|
||||
0 -> Right ViewChecked
|
||||
1 -> Right ViewTrusted
|
||||
2 -> Right ViewUnchecked
|
||||
_ -> Left $ "unknown view-tree View Contract provenance tag: " ++ show tag
|
||||
|
||||
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
|
||||
30
src/Eval.hs
30
src/Eval.hs
@@ -1,5 +1,6 @@
|
||||
module Eval where
|
||||
|
||||
import Frontend.ContractDesugar
|
||||
import Parser
|
||||
import Research
|
||||
|
||||
@@ -63,7 +64,7 @@ evalSingle env term
|
||||
in Map.insert "!result" res env
|
||||
|
||||
evalTricu :: Env -> [TricuAST] -> Env
|
||||
evalTricu env x = go env (reorderDefs env (map recoverParams x))
|
||||
evalTricu env x = go env (reorderDefs env (map recoverParams (desugarContracts x)))
|
||||
where
|
||||
go env' [] = env'
|
||||
go env' [def] =
|
||||
@@ -195,12 +196,37 @@ freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs)
|
||||
freeVars (SLet name val body) =
|
||||
Set.union (freeVars val) (Set.delete name (freeVars body))
|
||||
freeVars (SDef _ params body) = Set.difference (freeVars body) (Set.fromList params)
|
||||
freeVars (SDefAnn _ args _ body) = Set.difference (freeVars body) (Set.fromList (annotatedBinders args))
|
||||
freeVars (SDefAnn _ args ret body) =
|
||||
Set.difference
|
||||
(Set.unions
|
||||
[ freeVars body
|
||||
, freeVarsDefArgs args
|
||||
, maybe Set.empty freeVarsViewExpr ret
|
||||
, 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
|
||||
freeVars _ = Set.empty
|
||||
|
||||
freeVarsViewExpr :: ViewExpr -> Set String
|
||||
freeVarsViewExpr (VEName s) = Set.singleton s
|
||||
freeVarsViewExpr (VEVar s) = Set.singleton s
|
||||
freeVarsViewExpr (VEApp f a) = Set.union (freeVarsViewExpr f) (freeVarsViewExpr a)
|
||||
freeVarsViewExpr (VEList es) = Set.unions (map freeVarsViewExpr es)
|
||||
freeVarsViewExpr (VEForall _ e) = freeVarsViewExpr e
|
||||
freeVarsViewExpr (VEExists _ e) = freeVarsViewExpr e
|
||||
freeVarsViewExpr _ = Set.empty
|
||||
|
||||
freeVarsDefArgs :: [DefArg] -> Set String
|
||||
freeVarsDefArgs = Set.unions . map go
|
||||
where
|
||||
go (DefBinder _ mAnn) = maybe Set.empty freeVarsViewExpr mAnn
|
||||
go (DefPhantom ann) = freeVarsViewExpr ann
|
||||
|
||||
reorderDefs :: Env -> [TricuAST] -> [TricuAST]
|
||||
reorderDefs env defs
|
||||
| not (null missingDeps) =
|
||||
|
||||
154
src/FileEval.hs
154
src/FileEval.hs
@@ -1,6 +1,5 @@
|
||||
module FileEval
|
||||
( ContractMode(..)
|
||||
, LoadedSource(..)
|
||||
( LoadedSource(..)
|
||||
, preprocessFile
|
||||
, preprocessFileWithStore
|
||||
, preprocessFileWithResolver
|
||||
@@ -8,23 +7,17 @@ module FileEval
|
||||
, evaluateFileWithStore
|
||||
, evaluateFileWithContext
|
||||
, evaluateFileWithContextWithStore
|
||||
, evaluateFileWithContextWithStoreAndMode
|
||||
, evaluateFileResult
|
||||
, compileFile
|
||||
, compileFileWithStore
|
||||
, loadFileWithStore
|
||||
, loadFileWithStoreMode
|
||||
, loadFileWithResolver
|
||||
, defaultStorePath
|
||||
) where
|
||||
|
||||
import Check.Core
|
||||
( ImportedView(..)
|
||||
, checkProgramWithEnvAndImportedViews
|
||||
, importedViewsFromResolvedModulesEither
|
||||
, lowerViewExpr
|
||||
)
|
||||
import ContentStore
|
||||
import Eval (evalASTSync, evalTricu, freeVars, result)
|
||||
import Frontend.ContractDesugar (viewExprToAst)
|
||||
import Lexer
|
||||
import Module.Manifest
|
||||
import Module.Resolver
|
||||
@@ -52,11 +45,6 @@ extractMain env =
|
||||
Just evalResult -> Right evalResult
|
||||
Nothing -> Left "No `main` function detected"
|
||||
|
||||
data ContractMode
|
||||
= EnforceContracts
|
||||
| IgnoreContracts
|
||||
deriving (Eq, Show)
|
||||
|
||||
data LoadedSource = LoadedSource
|
||||
{ loadedImports :: Env
|
||||
, loadedAst :: [TricuAST]
|
||||
@@ -67,7 +55,6 @@ data LoadContext = LoadContext
|
||||
{ loadResolver :: ObjectResolver
|
||||
, loadStore :: Maybe StorePath
|
||||
, loadWorkspace :: Workspace
|
||||
, loadContracts :: ContractMode
|
||||
}
|
||||
|
||||
processImports :: [TricuAST] -> ([TricuAST], [(String, String)])
|
||||
@@ -100,14 +87,10 @@ evaluateFileWithContext :: Env -> FilePath -> IO Env
|
||||
evaluateFileWithContext = evaluateFileWithContextWithStore Nothing
|
||||
|
||||
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
|
||||
evaluateFileWithContextWithStore mStore env filePath = do
|
||||
loaded <- case mStore of
|
||||
Nothing -> loadFileMode mode filePath
|
||||
Just store -> loadFileWithStoreMode mode store filePath
|
||||
Nothing -> loadFile filePath
|
||||
Just store -> loadFileWithStore store filePath
|
||||
pure $ evalTricu (Map.union (loadedImports loaded) env) (loadedAst loaded)
|
||||
|
||||
preprocessFile :: FilePath -> IO [TricuAST]
|
||||
@@ -120,26 +103,20 @@ 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
|
||||
loadFile p = do
|
||||
store <- defaultStorePath
|
||||
loadFileWithStoreMode mode store p
|
||||
loadFileWithStore store p
|
||||
|
||||
loadFileWithStore :: StorePath -> FilePath -> IO LoadedSource
|
||||
loadFileWithStore = loadFileWithStoreMode EnforceContracts
|
||||
|
||||
loadFileWithStoreMode :: ContractMode -> StorePath -> FilePath -> IO LoadedSource
|
||||
loadFileWithStoreMode mode store p = do
|
||||
loadFileWithStore store p = do
|
||||
workspace <- findWorkspaceFor p
|
||||
resolver <- cachedFilesystemResolver store
|
||||
let ctx = LoadContext resolver (Just store) workspace mode
|
||||
let ctx = LoadContext resolver (Just store) workspace
|
||||
loadFile' ctx p
|
||||
|
||||
loadFileWithResolver :: ObjectResolver -> FilePath -> IO LoadedSource
|
||||
loadFileWithResolver resolver p = do
|
||||
let ctx = LoadContext resolver Nothing emptyWorkspace EnforceContracts
|
||||
let ctx = LoadContext resolver Nothing emptyWorkspace
|
||||
loadFile' ctx p
|
||||
|
||||
loadFile' :: LoadContext -> FilePath -> IO LoadedSource
|
||||
@@ -181,65 +158,37 @@ 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
|
||||
env = evalTricu (loadedImports loaded) asts
|
||||
explicitExports = topLevelExports 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
|
||||
importedViews <- importedViewsFromResolvedModulesEither (getViewType store) (loadedModules loaded)
|
||||
let localViewFacts = Map.map (\view -> (view, ViewChecked)) resolvedLocalViews
|
||||
importedViewFacts = Map.fromList [(importedViewName iv, (importedViewType iv, importedViewProvenance iv)) | iv <- importedViews]
|
||||
exportViewFacts = Map.union localViewFacts importedViewFacts
|
||||
exports <- mapM (buildExport env exportViewFacts) names
|
||||
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
|
||||
exports <- mapM (buildExport env) names
|
||||
manifestHash <- putManifest store (ModuleManifest [] exports)
|
||||
writeAlias store ModuleAlias (T.pack moduleName) (ObjectRef (unDomain manifestDomain) manifestHash)
|
||||
where
|
||||
buildExport env viewFacts name = case Map.lookup name env of
|
||||
Nothing -> errorWithoutStackTrace $ "Workspace module export not found after evaluation: " ++ name
|
||||
buildExport env (name, mContract) = case Map.lookup name env of
|
||||
Nothing -> errorWithoutStackTrace $
|
||||
"Workspace module export not found after evaluation: " ++ name
|
||||
Just term -> do
|
||||
let exportFact = Map.lookup name viewFacts
|
||||
exportView = fmap fst exportFact
|
||||
exportProvenance = fmap snd exportFact
|
||||
rootRef <- putViewTree store (singletonViewTreeWithProvenance exportFact term)
|
||||
viewRef <- mapM (putViewType store) exportView
|
||||
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 = rootRef
|
||||
, moduleExportAbi = "arboricx.abi.view-tree.v1"
|
||||
, moduleExportView = viewRef
|
||||
, moduleExportViewProvenance = exportProvenance
|
||||
, moduleExportObject = ObjectRef (unDomain treeTermDomain) rootRef
|
||||
, moduleExportAbi = "arboricx.abi.tree.v1"
|
||||
, moduleExportContract = mContractRef
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
isAnnotatedDefinition :: TricuAST -> Bool
|
||||
isAnnotatedDefinition SDefAnn {} = True
|
||||
isAnnotatedDefinition _ = False
|
||||
evaluateContract env c = return $ evalASTSync env (viewExprToAst c)
|
||||
|
||||
topLevelDefinitions :: [TricuAST] -> [String]
|
||||
topLevelDefinitions = mapMaybe go
|
||||
@@ -248,43 +197,12 @@ topLevelDefinitions = mapMaybe go
|
||||
go (SDefAnn name _ _ _) = Just name
|
||||
go _ = Nothing
|
||||
|
||||
topLevelDefinitionViews :: [TricuAST] -> Map.Map String ViewExpr
|
||||
topLevelDefinitionViews asts = Map.fromList (mapMaybe go asts)
|
||||
topLevelExports :: [TricuAST] -> [(String, Maybe ViewExpr)]
|
||||
topLevelExports = mapMaybe go
|
||||
where
|
||||
go (SDefAnn name args resultView _) = Just (name, definitionView args resultView)
|
||||
go (SExport name mContract) = Just (name, mContract)
|
||||
go _ = Nothing
|
||||
|
||||
resolveDefinitionViews :: Env -> Map.Map String ViewExpr -> Either String (Map.Map String ViewType)
|
||||
resolveDefinitionViews env = mapM (resolveViewExpression env)
|
||||
|
||||
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
|
||||
|
||||
84
src/Frontend/ContractDesugar.hs
Normal file
84
src/Frontend/ContractDesugar.hs
Normal file
@@ -0,0 +1,84 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Frontend.ContractDesugar
|
||||
( desugarContracts
|
||||
, viewExprToAst
|
||||
, withContractE
|
||||
) where
|
||||
|
||||
import Research
|
||||
|
||||
-- | Convert source-level contract annotations into runtime boundary checks.
|
||||
--
|
||||
-- A definition such as
|
||||
--
|
||||
-- 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').
|
||||
desugarContracts :: [TricuAST] -> [TricuAST]
|
||||
desugarContracts asts = map desugarTopItem asts
|
||||
where
|
||||
desugarTopItem (SDefAnn name args ret body) = desugarDefAnn name args ret body
|
||||
desugarTopItem other = other
|
||||
|
||||
desugarDefAnn :: String -> [DefArg] -> Maybe ViewExpr -> TricuAST -> TricuAST
|
||||
desugarDefAnn name args ret body = SDef name [] (wrapArgs args body')
|
||||
where
|
||||
body' = wrapReturn ret body
|
||||
|
||||
wrapReturn Nothing b = b
|
||||
wrapReturn (Just c) b =
|
||||
withContractE (viewExprToAst c) b (SLambda ["r"] (SVar "r" Nothing)) errCont
|
||||
|
||||
wrapArgs [] b = b
|
||||
wrapArgs (DefBinder nm Nothing : rest) b = SLambda [nm] (wrapArgs rest b)
|
||||
wrapArgs (DefBinder nm (Just c) : rest) b =
|
||||
SLambda [nm] $
|
||||
withContractE (viewExprToAst c) (SVar nm Nothing)
|
||||
(SLambda [nm] (wrapArgs rest b))
|
||||
errCont
|
||||
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.
|
||||
viewExprToAst :: ViewExpr -> TricuAST
|
||||
viewExprToAst = \case
|
||||
VEName s -> SVar s Nothing
|
||||
VEVar s -> SVar s Nothing
|
||||
VEInt i -> SInt i
|
||||
VEString s -> SStr s
|
||||
VEList es -> SList (map viewExprToAst es)
|
||||
VEApp f a -> SApp (viewExprToAst f) (viewExprToAst a)
|
||||
VERaw s -> SStr s
|
||||
VEVarId _ -> error "view variable ids are not supported by the frontend"
|
||||
VEForall _ _ -> error "forall annotations are not supported by the frontend"
|
||||
VEExists _ _ -> error "exists annotations are not supported by the frontend"
|
||||
|
||||
-- | Build an application of 'withContract' from the contract library.
|
||||
withContractE :: TricuAST -> TricuAST -> TricuAST -> TricuAST -> TricuAST
|
||||
withContractE contract value onOk onFail =
|
||||
SApp
|
||||
(SApp
|
||||
(SApp
|
||||
(SApp (SVar "withContract" Nothing) contract)
|
||||
value)
|
||||
onOk)
|
||||
onFail
|
||||
@@ -36,6 +36,7 @@ tricuLexer = do
|
||||
, try dot
|
||||
, try identifierWithHash
|
||||
, try keywordT
|
||||
, try lExport
|
||||
, try identifier
|
||||
, try namespace
|
||||
, try integerLiteral
|
||||
@@ -130,6 +131,9 @@ 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 '_'
|
||||
|
||||
57
src/Main.hs
57
src/Main.hs
@@ -1,18 +1,16 @@
|
||||
module Main where
|
||||
|
||||
import Check (checkFile, checkFileWithStore, instrumentIOContinuations)
|
||||
import ContentStore
|
||||
import ContentStore.Bundle
|
||||
import Module.Manifest
|
||||
import System.Exit (die)
|
||||
import Eval (evalTricu, mainResult, result)
|
||||
import FileEval
|
||||
( ContractMode(..)
|
||||
, LoadedSource(..)
|
||||
( LoadedSource(..)
|
||||
, defaultStorePath
|
||||
, evaluateFileWithContextWithStoreAndMode
|
||||
, evaluateFileWithContextWithStore
|
||||
, evaluateFileWithStore
|
||||
, loadFileWithStoreMode
|
||||
, loadFileWithStore
|
||||
, compileFileWithStore
|
||||
)
|
||||
import IODriver (IOPermissions(..), runIO)
|
||||
@@ -47,16 +45,11 @@ data AppArgs = AppArgs
|
||||
|
||||
data TricuArgs
|
||||
= Repl
|
||||
| Check
|
||||
{ checkInput :: FilePath
|
||||
, checkStore :: Maybe FilePath
|
||||
}
|
||||
| Eval
|
||||
{ evalFiles :: [FilePath]
|
||||
, evalStore :: Maybe FilePath
|
||||
, evalFormat :: EvaluatedForm
|
||||
, evalOutput :: FilePath
|
||||
, evalUnchecked :: Bool
|
||||
, evalIo :: Bool
|
||||
, evalAllowRead :: [FilePath]
|
||||
, evalAllowWrite :: [FilePath]
|
||||
@@ -112,16 +105,6 @@ 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..."))
|
||||
@@ -145,10 +128,6 @@ evalParser = Eval
|
||||
<> value ""
|
||||
<> help "Write output to file instead of stdout"
|
||||
)
|
||||
<*> 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"
|
||||
@@ -325,9 +304,7 @@ tricuParser = AppArgs
|
||||
<**> infoOption versionStr (long "version" <> help "Show version"))
|
||||
where
|
||||
topCommands = mconcat
|
||||
[ command "check" (info (checkParser <**> helper)
|
||||
(progDesc "Check View Contract annotations and report ok or diagnostics"))
|
||||
, command "eval" (info (evalParser <**> helper)
|
||||
[ 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"))
|
||||
@@ -374,7 +351,6 @@ main = do
|
||||
args = applyGlobalStore mGlobalStore (appCommand appArgs)
|
||||
case args of
|
||||
Repl -> runReplWithStore mGlobalStore
|
||||
Check {} -> runCheck args
|
||||
Eval {} -> runEval args
|
||||
ArboricxCompile {} -> runCompile args
|
||||
ArboricxImport {} -> runImport args
|
||||
@@ -390,7 +366,6 @@ main = do
|
||||
applyGlobalStore :: Maybe FilePath -> TricuArgs -> TricuArgs
|
||||
applyGlobalStore mGlobal args = case args of
|
||||
Repl -> Repl
|
||||
Check {} -> args { checkStore = preferLocal (checkStore args) }
|
||||
Eval {} -> args { evalStore = preferLocal (evalStore args) }
|
||||
ArboricxCompile {} -> args { compileStore = preferLocal (compileStore args) }
|
||||
ArboricxImport {} -> args { importStore = preferLocal (importStore args) }
|
||||
@@ -413,22 +388,6 @@ runReplWithStore mStore = do
|
||||
Nothing -> repl
|
||||
Just store -> replWithStore (StorePath store)
|
||||
|
||||
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
|
||||
@@ -441,12 +400,7 @@ runEval opts = do
|
||||
return $ result env
|
||||
_ -> do
|
||||
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
|
||||
finalEnv <- foldM (evaluateFileWithContextWithStore mStoreOpt) Map.empty files
|
||||
return $ mainResult finalEnv
|
||||
finalT <- if evalIo opts
|
||||
then do
|
||||
@@ -489,7 +443,6 @@ runImport opts = do
|
||||
(treeTermRef root)
|
||||
"arboricx.abi.tree.v1"
|
||||
Nothing
|
||||
Nothing
|
||||
| (name, root) <- roots
|
||||
]
|
||||
moduleName = T.pack $ maybe (takeBaseName file) id (importModule opts)
|
||||
|
||||
@@ -12,7 +12,6 @@ module Module.Manifest
|
||||
import ContentStore.Filesystem (getObject, putObject)
|
||||
import ContentStore.Object
|
||||
import ContentStore.Alias (ObjectRef(..))
|
||||
import Research (ViewProvenance(..))
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Text (Text)
|
||||
@@ -36,13 +35,13 @@ data ModuleReference = ModuleReference
|
||||
, moduleReferenceRef :: ObjectRef
|
||||
} deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Exported executable artifact plus optional direct View Contract type.
|
||||
-- | Exported executable artifact. Optional contract terms are ordinary tree
|
||||
-- terms referenced from elsewhere in the store, not a special artifact kind.
|
||||
data ModuleExport = ModuleExport
|
||||
{ moduleExportName :: Text
|
||||
, moduleExportObject :: ObjectRef
|
||||
, moduleExportAbi :: Text
|
||||
, moduleExportView :: Maybe ObjectRef
|
||||
, moduleExportViewProvenance :: Maybe ViewProvenance
|
||||
{ moduleExportName :: Text
|
||||
, moduleExportObject :: ObjectRef
|
||||
, moduleExportAbi :: Text
|
||||
, moduleExportContract :: Maybe ObjectRef
|
||||
} deriving (Eq, Ord, Show)
|
||||
|
||||
manifestDomain :: Domain
|
||||
@@ -60,16 +59,17 @@ encodeManifest manifest = encodeUtf8 $ Text.unlines $
|
||||
, 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)
|
||||
, maybe "-" encodeProvenance (moduleExportViewProvenance ex)
|
||||
]
|
||||
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)
|
||||
|
||||
-- | Parse the canonical manifest encoding.
|
||||
decodeManifest :: ByteString -> Either String ModuleManifest
|
||||
@@ -87,27 +87,19 @@ decodeManifest bs = do
|
||||
["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
|
||||
-- Legacy manifests predate explicit View Contract provenance. Keep
|
||||
-- the decoded field absent; checker import code treats absent
|
||||
-- provenance as ViewUnchecked/Assumed at the use boundary.
|
||||
view <- optionalRef viewKind viewHash
|
||||
["export", name, kind, hash, abi] -> do
|
||||
ex <- ModuleExport
|
||||
<$> unesc name
|
||||
<*> (ObjectRef <$> unesc kind <*> unesc hash)
|
||||
<*> unesc abi
|
||||
<*> pure view
|
||||
<*> pure Nothing
|
||||
Right manifest { moduleManifestExports = moduleManifestExports manifest ++ [ex] }
|
||||
["export", name, kind, hash, abi, viewKind, viewHash, provenanceText] -> do
|
||||
view <- optionalRef viewKind viewHash
|
||||
provenance <- optionalProvenance provenanceText
|
||||
["export", name, kind, hash, abi, ckind, chash] -> do
|
||||
ex <- ModuleExport
|
||||
<$> unesc name
|
||||
<*> (ObjectRef <$> unesc kind <*> unesc hash)
|
||||
<*> unesc abi
|
||||
<*> pure view
|
||||
<*> pure provenance
|
||||
<*> (Just <$> (ObjectRef <$> unesc ckind <*> unesc chash))
|
||||
Right manifest { moduleManifestExports = moduleManifestExports manifest ++ [ex] }
|
||||
_ -> Left $ "invalid module manifest row: " ++ Text.unpack line
|
||||
|
||||
@@ -123,22 +115,6 @@ getManifest store h = do
|
||||
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)
|
||||
|
||||
encodeProvenance :: ViewProvenance -> Text
|
||||
encodeProvenance ViewChecked = "checked"
|
||||
encodeProvenance ViewTrusted = "trusted"
|
||||
encodeProvenance ViewUnchecked = "unchecked"
|
||||
|
||||
optionalProvenance :: Text -> Either String (Maybe ViewProvenance)
|
||||
optionalProvenance "-" = Right Nothing
|
||||
optionalProvenance "checked" = Right (Just ViewChecked)
|
||||
optionalProvenance "trusted" = Right (Just ViewTrusted)
|
||||
optionalProvenance "unchecked" = Right (Just ViewUnchecked)
|
||||
optionalProvenance other = Left $ "invalid View Contract provenance: " ++ Text.unpack other
|
||||
|
||||
esc :: Text -> Text
|
||||
esc = Text.concatMap $ \c -> case c of
|
||||
'%' -> "%25"
|
||||
|
||||
@@ -9,7 +9,6 @@ module Module.Resolver
|
||||
|
||||
import ContentStore.Alias
|
||||
import ContentStore.Arboricx (decodeTreeTerm, treeTermDomain)
|
||||
import ContentStore.ViewTree (decodeViewTree, viewTreeKind, viewTreeRootTerm)
|
||||
import ContentStore.Object
|
||||
import ContentStore.Resolver
|
||||
import Module.Manifest
|
||||
@@ -20,15 +19,14 @@ 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.
|
||||
-- The executable term is loaded directly; contract terms are not interpreted by
|
||||
-- the resolver.
|
||||
data ResolvedExport = ResolvedExport
|
||||
{ resolvedExportSourceName :: T.Text
|
||||
, resolvedExportLocalName :: String
|
||||
, resolvedExportObject :: ObjectRef
|
||||
, resolvedExportAbi :: T.Text
|
||||
, resolvedExportView :: Maybe ObjectRef
|
||||
, resolvedExportProvenance :: Maybe ViewProvenance
|
||||
, resolvedExportContract :: Maybe ObjectRef
|
||||
, resolvedExportTerm :: T
|
||||
} deriving (Show, Eq)
|
||||
|
||||
@@ -86,23 +84,14 @@ resolveModuleExport resolver namespace ex = do
|
||||
, resolvedExportLocalName = nsVariable namespace (T.unpack sourceName)
|
||||
, resolvedExportObject = ref
|
||||
, resolvedExportAbi = moduleExportAbi ex
|
||||
, resolvedExportView = moduleExportView ex
|
||||
, resolvedExportProvenance = moduleExportViewProvenance ex
|
||||
, resolvedExportContract = moduleExportContract 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"
|
||||
bytes <- requireObject
|
||||
case decodeTreeTerm bytes of
|
||||
Left err -> errorWithoutStackTrace $
|
||||
"Module export " ++ show (T.unpack sourceName)
|
||||
@@ -112,16 +101,15 @@ resolveExportTerm resolver sourceName ref
|
||||
| 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))
|
||||
++ "; expected " ++ show (T.unpack (unDomain treeTermDomain))
|
||||
where
|
||||
requireObject label = do
|
||||
requireObject = 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)
|
||||
++ " references missing tree term " ++ T.unpack (objectRefHash ref)
|
||||
++ " (kind " ++ T.unpack (objectRefKind ref) ++ ")"
|
||||
|
||||
resolvedModulesEnv :: [ResolvedModule] -> Env
|
||||
|
||||
@@ -69,9 +69,12 @@ manyItemsP = do
|
||||
topItemP :: TokParser TricuAST
|
||||
topItemP = do
|
||||
toks <- getInput
|
||||
case definitionHeadTop toks of
|
||||
Just _ -> definitionP
|
||||
Nothing -> exprTopP
|
||||
case toks of
|
||||
LExport : _ -> exportP
|
||||
_ ->
|
||||
case definitionHeadTop toks of
|
||||
Just _ -> definitionP
|
||||
Nothing -> exprTopP
|
||||
|
||||
definitionHeadTop :: [LToken] -> Maybe (String, [String])
|
||||
definitionHeadTop toks =
|
||||
@@ -218,6 +221,13 @@ 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
|
||||
|
||||
63
src/REPL.hs
63
src/REPL.hs
@@ -1,12 +1,10 @@
|
||||
module REPL where
|
||||
|
||||
import Check (checkFileWithStore)
|
||||
import Eval (evalTricu, result)
|
||||
import FileEval
|
||||
( ContractMode(..)
|
||||
, LoadedSource(..)
|
||||
( LoadedSource(..)
|
||||
, defaultStorePath
|
||||
, loadFileWithStoreMode
|
||||
, loadFileWithStore
|
||||
)
|
||||
import Parser (parseTricu)
|
||||
import Research (EvaluatedForm(..), Env, formatT)
|
||||
@@ -35,14 +33,12 @@ import qualified Data.Map as Map
|
||||
import qualified Data.Text 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.
|
||||
-- CLI.
|
||||
data REPLState = REPLState
|
||||
{ replForm :: EvaluatedForm
|
||||
, replEnv :: Env
|
||||
, replStore :: StorePath
|
||||
, replContracts :: ContractMode
|
||||
, replEnvRef :: IORef Env
|
||||
{ replForm :: EvaluatedForm
|
||||
, replEnv :: Env
|
||||
, replStore :: StorePath
|
||||
, replEnvRef :: IORef Env
|
||||
}
|
||||
|
||||
repl :: IO ()
|
||||
@@ -56,7 +52,7 @@ replWithStore store = do
|
||||
, historyFile = Just "~/.local/state/tricu/history"
|
||||
, autoAddHistory = True
|
||||
}
|
||||
runInputT settings (loop (REPLState Decode Map.empty store EnforceContracts envRef))
|
||||
runInputT settings (loop (REPLState Decode Map.empty store envRef))
|
||||
where
|
||||
|
||||
loop :: REPLState -> InputT IO ()
|
||||
@@ -78,12 +74,10 @@ replWithStore store = do
|
||||
"!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)
|
||||
| "!use" `isPrefixOf` s -> handleUse state (strip $ drop 4 s)
|
||||
| "!name" `isPrefixOf` s -> handleName state (strip $ drop 5 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)
|
||||
@@ -102,9 +96,7 @@ replWithStore store = do
|
||||
outputStrLn " !load FILE - Load and evaluate a .tri file into the environment"
|
||||
outputStrLn " !use MODULE [NS] - Load a module alias/manifest from the store (NS defaults to !Local)"
|
||||
outputStrLn " !name NAME [LOCAL] - Load a name alias/tree-term hash from the store"
|
||||
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 ()
|
||||
@@ -135,24 +127,12 @@ replWithStore store = do
|
||||
if not exists
|
||||
then outputStrLn ("File not found: " ++ path) >> loop state
|
||||
else do
|
||||
loaded <- liftIO $ loadFileWithStoreMode (replContracts state) (replStore state) path
|
||||
loaded <- liftIO $ loadFileWithStore (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
|
||||
|
||||
handleUse :: REPLState -> String -> InputT IO ()
|
||||
handleUse state arg = case words arg of
|
||||
[] -> outputStrLn "Usage: !use MODULE [NAMESPACE]" >> loop state
|
||||
@@ -205,23 +185,6 @@ replWithStore store = do
|
||||
outputStrLn $ "Store changed to: " ++ path
|
||||
loop state { replStore = StorePath path }
|
||||
|
||||
handleUnchecked :: REPLState -> String -> InputT IO ()
|
||||
handleUnchecked state arg = setUnchecked state arg
|
||||
|
||||
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 }
|
||||
|
||||
reportContracts :: REPLState -> InputT IO ()
|
||||
reportContracts state = outputStrLn $ contractModeMessage (replContracts state)
|
||||
|
||||
handleEnv :: REPLState -> InputT IO ()
|
||||
handleEnv state =
|
||||
case sort (Map.keys (replEnv state)) of
|
||||
@@ -263,12 +226,10 @@ completeRepl envRef input@(left, _right)
|
||||
, "!load"
|
||||
, "!use"
|
||||
, "!name"
|
||||
, "!check"
|
||||
, "!store"
|
||||
, "!unchecked"
|
||||
, "!env"
|
||||
]
|
||||
commandWantsFile inputLine = any (`isPrefixOf` inputLine) ["!load ", "!check "]
|
||||
commandWantsFile inputLine = "!load " `isPrefixOf` inputLine
|
||||
termBreakChars = " \t\n\r()[]{}\"'"
|
||||
|
||||
outputFormats :: [EvaluatedForm]
|
||||
@@ -286,10 +247,6 @@ readEvaluatedForm s = case s of
|
||||
"string" -> Just StringLit
|
||||
_ -> Nothing
|
||||
|
||||
contractModeMessage :: ContractMode -> String
|
||||
contractModeMessage EnforceContracts = "Contracts: on"
|
||||
contractModeMessage IgnoreContracts = "Contracts: off (unchecked eval)"
|
||||
|
||||
storePathString :: StorePath -> FilePath
|
||||
storePathString (StorePath path) = path
|
||||
|
||||
|
||||
@@ -19,40 +19,10 @@ 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 ViewProvenance
|
||||
= ViewChecked
|
||||
| ViewTrusted
|
||||
| ViewUnchecked
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data ViewType
|
||||
= VTName String
|
||||
| VTVar Integer
|
||||
| VTRefRaw ViewRef
|
||||
| VTList ViewType
|
||||
| VTMaybe ViewType
|
||||
| VTPair ViewType ViewType
|
||||
| VTResult ViewType ViewType
|
||||
| VTGuarded ViewType T
|
||||
| VTForall [Integer] ViewType
|
||||
| VTExists [Integer] ViewType
|
||||
| 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, VTVar, VTRef, VTRefText, VTList, VTMaybe, VTPair, VTResult, VTGuarded, VTForall, VTExists, VTFn #-}
|
||||
|
||||
-- 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.
|
||||
data ViewExpr
|
||||
= VEName String
|
||||
| VEVar String
|
||||
@@ -91,6 +61,7 @@ data TricuAST
|
||||
| SLet String TricuAST TricuAST
|
||||
| SEmpty
|
||||
| SImport String String
|
||||
| SExport String (Maybe ViewExpr)
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- Lexer Tokens
|
||||
@@ -100,6 +71,7 @@ data LToken
|
||||
| LKeywordT
|
||||
| LNamespace String
|
||||
| LImport String String
|
||||
| LExport
|
||||
| LAssign
|
||||
| LAssignAt
|
||||
| LAt
|
||||
|
||||
Reference in New Issue
Block a user