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.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 directly; contract terms are not interpreted by
-- the resolver.
data ResolvedExport = ResolvedExport
  { resolvedExportSourceName :: T.Text
  , resolvedExportLocalName  :: String
  , resolvedExportObject     :: ObjectRef
  , resolvedExportAbi        :: T.Text
  , resolvedExportContract   :: 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
        , resolvedExportContract = moduleExportContract ex
        , resolvedExportTerm = term
        }

resolveExportTerm :: ObjectResolver -> T.Text -> ObjectRef -> IO T
resolveExportTerm resolver sourceName ref
  | objectRefKind ref == unDomain treeTermDomain = do
      bytes <- requireObject
      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 (unDomain treeTermDomain))
  where
    requireObject = do
      mBytes <- resolverObject resolver ref
      case mBytes of
        Just bytes -> return bytes
        Nothing -> errorWithoutStackTrace $
          "Module export " ++ show (T.unpack sourceName)
          ++ " references missing tree term " ++ 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