tricu/src/Module/Resolver.hs

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
  , resolvedExportProvenance :: Maybe ViewProvenance
  , 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
        , resolvedExportProvenance = moduleExportViewProvenance 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