tricu

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

FileEval.hs (9095B)

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