Tricu 2.0.0

Sorry for squashing all of this but 🤷

src/Module/Resolver.hs

@@ -0,0 +1,153 @@
+module Module.Resolver
+  ( ResolvedExport(..)
+  , ResolvedModule(..)
+  , resolveModuleImport
+  , resolveModuleImportSelecting
+  , resolveModuleImports
+  , resolvedModulesEnv
+  ) where
+
+import ContentStore.Alias
+import ContentStore.Arboricx (decodeTreeTerm, treeTermDomain)
+import ContentStore.ViewTree (decodeViewTree, viewTreeKind, viewTreeRootTerm)
+import ContentStore.Object
+import ContentStore.Resolver
+import Module.Manifest
+import Research
+
+import qualified Data.Map as Map
+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.
+data ResolvedExport = ResolvedExport
+  { resolvedExportSourceName :: T.Text
+  , resolvedExportLocalName  :: String
+  , resolvedExportObject     :: ObjectRef
+  , resolvedExportAbi        :: T.Text
+  , resolvedExportView       :: Maybe ObjectRef
+  , resolvedExportTerm       :: T
+  } deriving (Show, Eq)
+
+data ResolvedModule = ResolvedModule
+  { resolvedModuleTarget    :: String
+  , resolvedModuleNamespace :: String
+  , resolvedModuleManifest  :: ObjectHash
+  , resolvedModuleExports   :: [ResolvedExport]
+  } deriving (Show, Eq)
+
+resolveModuleImports :: ObjectResolver -> [TricuAST] -> IO ([ResolvedModule], [TricuAST])
+resolveModuleImports resolver asts = do
+  let (imports, nonImports) = foldr splitImport ([], []) asts
+  modules <- mapM (uncurry (resolveModuleImport resolver)) imports
+  return (modules, nonImports)
+  where
+    splitImport (SImport target namespace) (is, rest) = ((target, namespace) : is, rest)
+    splitImport ast (is, rest) = (is, ast : rest)
+
+resolveModuleImport :: ObjectResolver -> String -> String -> IO ResolvedModule
+resolveModuleImport resolver moduleTarget namespace =
+  resolveModuleImportSelecting resolver Nothing moduleTarget namespace
+
+resolveModuleImportSelecting :: ObjectResolver -> Maybe (Set.Set T.Text) -> String -> String -> IO ResolvedModule
+resolveModuleImportSelecting resolver selected moduleTarget namespace = do
+  manifestHash <- resolveModuleManifestHash resolver moduleTarget
+  mManifest <- resolveManifest resolver manifestHash
+  manifest <- case mManifest of
+    Nothing -> errorWithoutStackTrace $
+      "Module import failed for " ++ show moduleTarget
+      ++ " as " ++ show namespace
+      ++ ": manifest object not found (kind " ++ T.unpack (unDomain manifestDomain)
+      ++ ", hash " ++ T.unpack manifestHash ++ ")"
+    Just value -> return value
+  let wantedExports = case selected of
+        Nothing -> moduleManifestExports manifest
+        Just names -> filter (\ex -> moduleExportName ex `Set.member` names) (moduleManifestExports manifest)
+  exports <- mapM (resolveModuleExport resolver localNamespace) wantedExports
+  return ResolvedModule
+    { resolvedModuleTarget = moduleTarget
+    , resolvedModuleNamespace = namespace
+    , resolvedModuleManifest = manifestHash
+    , resolvedModuleExports = exports
+    }
+  where
+    localNamespace = if namespace == "!Local" then "" else namespace
+
+resolveModuleExport :: ObjectResolver -> String -> ModuleExport -> IO ResolvedExport
+resolveModuleExport resolver namespace ex = do
+  let ref = moduleExportObject ex
+      sourceName = moduleExportName ex
+  term <- resolveExportTerm resolver sourceName ref
+  return ResolvedExport
+        { resolvedExportSourceName = sourceName
+        , resolvedExportLocalName = nsVariable namespace (T.unpack sourceName)
+        , resolvedExportObject = ref
+        , resolvedExportAbi = moduleExportAbi ex
+        , resolvedExportView = moduleExportView 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"
+      case decodeTreeTerm bytes of
+        Left err -> errorWithoutStackTrace $
+          "Module export " ++ show (T.unpack sourceName)
+          ++ " references invalid tree term " ++ T.unpack (objectRefHash ref)
+          ++ ": " ++ err
+        Right term -> return term
+  | 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))
+  where
+    requireObject label = 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)
+          ++ " (kind " ++ T.unpack (objectRefKind ref) ++ ")"
+
+resolvedModulesEnv :: [ResolvedModule] -> Env
+resolvedModulesEnv modules = Map.fromList
+  [ (resolvedExportLocalName ex, resolvedExportTerm ex)
+  | m <- modules
+  , ex <- resolvedModuleExports m
+  ]
+
+resolveModuleManifestHash :: ObjectResolver -> String -> IO ObjectHash
+resolveModuleManifestHash resolver moduleTarget = do
+  mAlias <- resolverAlias resolver ModuleAlias (T.pack moduleTarget)
+  case mAlias of
+    Just ref ->
+      if objectRefKind ref == unDomain manifestDomain
+        then return (objectRefHash ref)
+        else errorWithoutStackTrace $
+          "Module alias " ++ show moduleTarget
+          ++ " points at unsupported object kind " ++ show (T.unpack (objectRefKind ref))
+          ++ "; expected " ++ show (T.unpack (unDomain manifestDomain))
+          ++ " (hash " ++ T.unpack (objectRefHash ref) ++ ")"
+    Nothing ->
+      case textToHashBytes (T.pack moduleTarget) of
+        Right _ -> return (T.pack moduleTarget)
+        Left _ -> errorWithoutStackTrace $
+          "Module alias not found: " ++ show moduleTarget
+          ++ "; add it to tricu.workspace or write a ModuleAlias, or import by manifest hash"
+
+nsVariable :: String -> String -> String
+nsVariable "" name = name
+nsVariable moduleName name = moduleName ++ "." ++ name