tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

FileEval.hs (9900B)

      1 module FileEval
      2   ( LoadedSource(..)
      3   , preprocessFile
      4   , preprocessFileWithStore
      5   , preprocessFileWithResolver
      6   , evaluateFile
      7   , evaluateFileWithStore
      8   , evaluateFileWithContext
      9   , evaluateFileWithContextWithStore
     10   , evaluateFileResult
     11   , compileFile
     12   , compileFileWithStore
     13   , loadFileWithStore
     14   , loadFileWithResolver
     15   , loadWorkspaceExportWithStore
     16   , defaultStorePath
     17   ) where
     18 
     19 import ContentStore
     20 import Eval (evalTricu, freeVars, result, injectKernel)
     21 import Frontend.ContractDesugar (desugarContracts)
     22 import Lexer
     23 import Module.Manifest
     24 import Module.Resolver
     25 import Module.Workspace
     26 import Parser
     27 import Research
     28 import Wire (buildBundle, encodeBundle, decodeBundle, verifyBundle, Bundle(..))
     29 
     30 import Data.List       (partition, isPrefixOf)
     31 import Data.Maybe      (mapMaybe)
     32 import System.Directory (getHomeDirectory, getTemporaryDirectory)
     33 import System.FilePath ((</>))
     34 import System.Exit (die)
     35 
     36 import qualified Data.ByteString as BS
     37 import qualified Data.ByteString.Lazy as BL
     38 import qualified Data.Map as Map
     39 import qualified Data.Set as Set
     40 import qualified Data.Sequence as Seq
     41 import qualified Data.Text as T
     42 
     43 extractMain :: Env -> Either String T
     44 extractMain env =
     45   case Map.lookup "main" env of
     46     Just evalResult -> Right evalResult
     47     Nothing -> Left "No `main` function detected"
     48 
     49 data LoadedSource = LoadedSource
     50   { loadedImports :: Env
     51   , loadedAst     :: [TricuAST]
     52   , loadedModules :: [ResolvedModule]
     53   }
     54 
     55 data LoadContext = LoadContext
     56   { loadResolver  :: ObjectResolver
     57   , loadStore     :: Maybe StorePath
     58   , loadWorkspace :: Workspace
     59   }
     60 
     61 processImports :: [TricuAST] -> ([TricuAST], [(String, String)])
     62 processImports asts =
     63   let (imports, nonImports) = partition isImp asts
     64       importTargets = mapMaybe getImportInfo imports
     65   in (nonImports, importTargets)
     66   where
     67     isImp (SImport _ _) = True
     68     isImp _ = False
     69     getImportInfo (SImport p n) = Just (p, n)
     70     getImportInfo _ = Nothing
     71 
     72 evaluateFileResult :: FilePath -> IO T
     73 evaluateFileResult filePath = do
     74   env <- evaluateFile filePath
     75   case extractMain env of
     76     Right evalResult -> return evalResult
     77     Left err -> errorWithoutStackTrace err
     78 
     79 evaluateFile :: FilePath -> IO Env
     80 evaluateFile = evaluateFileWithStore Nothing
     81 
     82 evaluateFileWithStore :: Maybe StorePath -> FilePath -> IO Env
     83 evaluateFileWithStore mStore filePath = do
     84   loaded <- maybe loadFile loadFileWithStore mStore filePath
     85   pure $ evalTricu (injectKernel (loadedImports loaded)) (loadedAst loaded)
     86 
     87 evaluateFileWithContext :: Env -> FilePath -> IO Env
     88 evaluateFileWithContext = evaluateFileWithContextWithStore Nothing
     89 
     90 evaluateFileWithContextWithStore :: Maybe StorePath -> Env -> FilePath -> IO Env
     91 evaluateFileWithContextWithStore mStore env filePath = do
     92   loaded <- case mStore of
     93     Nothing    -> loadFile filePath
     94     Just store -> loadFileWithStore store filePath
     95   pure $ evalTricu (injectKernel (Map.union (loadedImports loaded) env)) (loadedAst loaded)
     96 
     97 preprocessFile :: FilePath -> IO [TricuAST]
     98 preprocessFile p = loadedAst <$> loadFile p
     99 
    100 preprocessFileWithStore :: StorePath -> FilePath -> IO [TricuAST]
    101 preprocessFileWithStore store p = loadedAst <$> loadFileWithStore store p
    102 
    103 preprocessFileWithResolver :: ObjectResolver -> FilePath -> IO [TricuAST]
    104 preprocessFileWithResolver resolver p = loadedAst <$> loadFileWithResolver resolver p
    105 
    106 loadFile :: FilePath -> IO LoadedSource
    107 loadFile p = do
    108   store <- defaultStorePath
    109   loadFileWithStore store p
    110 
    111 loadFileWithStore :: StorePath -> FilePath -> IO LoadedSource
    112 loadFileWithStore store p = do
    113   workspace <- findWorkspaceFor p
    114   resolver <- cachedFilesystemResolver store
    115   let ctx = LoadContext resolver (Just store) workspace
    116   loadFile' ctx p
    117 
    118 loadFileWithResolver :: ObjectResolver -> FilePath -> IO LoadedSource
    119 loadFileWithResolver resolver p = do
    120   let ctx = LoadContext resolver Nothing emptyWorkspace
    121   loadFile' ctx p
    122 
    123 -- Load a library entry through the same workspace/bootstrap boundary as an
    124 -- authored import, without a generated source file or source interpolation.
    125 loadWorkspaceExportWithStore :: StorePath -> FilePath -> String -> String -> IO T
    126 loadWorkspaceExportWithStore store contextPath target exportName = do
    127   workspace <- findWorkspaceFor contextPath
    128   resolver <- cachedFilesystemResolver store
    129   let ctx = LoadContext resolver (Just store) workspace
    130   ensureWorkspaceModule ctx target
    131   resolved <- resolveModuleImportSelecting resolver
    132     (Just $ Set.singleton $ T.pack exportName) target "!Local"
    133   case Map.lookup exportName (resolvedModulesEnv [resolved]) of
    134     Just term -> pure term
    135     Nothing -> die $ "Module export not found: " ++ target ++ "." ++ exportName
    136 
    137 loadFile' :: LoadContext -> FilePath -> IO LoadedSource
    138 loadFile' ctx currentPath = do
    139   contents <- readFile currentPath
    140   let tokens = lexTricu contents
    141   case parseProgram tokens of
    142     Left err -> errorWithoutStackTrace (handleParseError tokens err)
    143     Right ast ->
    144       let (nonImports, importTargets) = processImports ast
    145           desugaredNonImports = desugarContracts nonImports
    146       in do
    147         let reexportOnlyModule = null desugaredNonImports && not (null importTargets)
    148         resolvedModules <- mapM (\(target, name) -> do
    149             ensureWorkspaceModule ctx target
    150             resolveModuleImportSelecting (loadResolver ctx) (selectedExportsForImport reexportOnlyModule target name desugaredNonImports) target name) importTargets
    151         let moduleEnv = resolvedModulesEnv resolvedModules
    152         pure LoadedSource
    153           { loadedImports = moduleEnv
    154           , loadedAst = desugaredNonImports
    155           , loadedModules = resolvedModules
    156           }
    157 
    158 ensureWorkspaceModule :: LoadContext -> String -> IO ()
    159 ensureWorkspaceModule ctx moduleTarget = do
    160   existing <- resolverAlias (loadResolver ctx) ModuleAlias (T.pack moduleTarget)
    161   case existing of
    162     Just _ -> return ()
    163     Nothing -> do
    164       mSource <- resolveSourceModulePath ctx moduleTarget
    165       case (loadStore ctx, mSource) of
    166         (Just store, Just sourcePath) -> buildWorkspaceModule ctx store moduleTarget sourcePath
    167         _ -> return ()
    168 
    169 resolveSourceModulePath :: LoadContext -> String -> IO (Maybe FilePath)
    170 resolveSourceModulePath ctx moduleTarget =
    171   return (lookupWorkspaceModule (loadWorkspace ctx) (T.pack moduleTarget))
    172 
    173 buildWorkspaceModule :: LoadContext -> StorePath -> String -> FilePath -> IO ()
    174 buildWorkspaceModule ctx store moduleName sourcePath = do
    175   loaded <- loadFile' ctx sourcePath
    176   let asts = loadedAst loaded
    177       env = evalTricu (loadedImports loaded) asts
    178       localNames = topLevelDefinitions asts
    179       names = if null localNames
    180                 then filter (/= "!result") (Map.keys env)
    181                 else localNames
    182   exports <- mapM (buildExport env) names
    183   manifestHash <- putManifest store (ModuleManifest [] exports)
    184   writeAlias store ModuleAlias (T.pack moduleName) (ObjectRef (unDomain manifestDomain) manifestHash)
    185   where
    186     buildExport env name = case Map.lookup name env of
    187       Nothing -> errorWithoutStackTrace $
    188         "Workspace module export not found after evaluation: " ++ name
    189       Just term -> do
    190         rootRef <- putTreeTerm store term
    191         return ModuleExport
    192           { moduleExportName = T.pack name
    193           , moduleExportObject = ObjectRef (unDomain treeTermDomain) rootRef
    194           , moduleExportAbi = "arboricx.abi.tree.v1"
    195           }
    196 
    197 topLevelDefinitions :: [TricuAST] -> [String]
    198 topLevelDefinitions = mapMaybe go
    199   where
    200     go (SDef name _ _) = Just name
    201     go (SDefAnn name _ _ _) = Just name
    202     go _ = Nothing
    203 
    204 defaultStorePath :: IO StorePath
    205 defaultStorePath = do
    206   home <- getHomeDirectory
    207   if home == "/homeless-shelter"
    208     then do
    209       tmp <- getTemporaryDirectory
    210       return (StorePath (tmp </> "tricu" </> "store"))
    211     else return (StorePath (home </> ".tricu" </> "store"))
    212 
    213 selectedExportsForImport :: Bool -> String -> String -> [TricuAST] -> Maybe (Set.Set T.Text)
    214 selectedExportsForImport True _ _ _ = Nothing
    215 selectedExportsForImport False _moduleTarget importNamespace asts =
    216   Just $ Set.fromList directSelections
    217   where
    218     directSelections = mapMaybe select (Set.toList used)
    219     used = foldMap freeVars asts
    220     prefix = importNamespace ++ "."
    221     select name
    222       | importNamespace == "!Local" = Just (T.pack name)
    223       | prefix `isPrefixOf` name = Just (T.pack (drop (length prefix) name))
    224       | otherwise = Nothing
    225 
    226 -- | Compile a tricu source file to a standalone Arboricx bundle.
    227 -- Emits a canonical indexed bundle with no SHA-256 hashing.
    228 compileFile :: FilePath -> FilePath -> [T.Text] -> IO ()
    229 compileFile = compileFileWithStore Nothing
    230 
    231 compileFileWithStore :: Maybe StorePath -> FilePath -> FilePath -> [T.Text] -> IO ()
    232 compileFileWithStore mStore inputPath outputPath maybeNames = do
    233   env <- evaluateFileWithStore mStore inputPath
    234   let defaultNames = ["main"]
    235       wantedNames  = if null maybeNames then defaultNames else maybeNames
    236       wantedNamesUnpacked = map T.unpack wantedNames
    237   compiledTerms <- mapM (\n -> case Map.lookup n env of
    238     Nothing -> die $ "No definition '" ++ n ++ "' found in " ++ inputPath
    239     Just t  -> return (T.pack n, t)) wantedNamesUnpacked
    240   let bundle = buildBundle compiledTerms
    241       bundleData = encodeBundle bundle
    242       nodeCount = Seq.length (bundleNodes bundle)
    243       bundleSize = BS.length bundleData
    244   BL.writeFile outputPath (BL.fromStrict bundleData)
    245   putStrLn $ "Compiled " ++ inputPath ++ " -> " ++ outputPath
    246   putStrLn $ "  exports: " ++ T.unpack (T.intercalate ", " (map fst compiledTerms))
    247   putStrLn $ "  nodes: " ++ show nodeCount
    248   putStrLn $ "  size: " ++ show bundleSize ++ " bytes"
    249   case decodeBundle bundleData of
    250     Left err -> putStrLn $ "  round-trip decode failed: " ++ err
    251     Right decoded -> case verifyBundle decoded of
    252       Left err -> putStrLn $ "  round-trip verify failed: " ++ err
    253       Right () -> putStrLn $ "  round-trip: OK"