tricu

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

Resolver.hs (5891B)

      1 module Module.Resolver
      2   ( ResolvedExport(..)
      3   , ResolvedModule(..)
      4   , resolveModuleImport
      5   , resolveModuleImportSelecting
      6   , resolveModuleImports
      7   , resolvedModulesEnv
      8   ) where
      9 
     10 import ContentStore.Alias
     11 import ContentStore.Arboricx (decodeTreeTerm, treeTermDomain)
     12 import ContentStore.Object
     13 import ContentStore.Resolver
     14 import Module.Manifest
     15 import Research
     16 
     17 import qualified Data.Map as Map
     18 import qualified Data.Set as Set
     19 import qualified Data.Text as T
     20 
     21 -- | A manifest export resolved into the importing source's local lexical scope.
     22 -- The executable term is loaded directly; contract terms are not interpreted by
     23 -- the resolver.
     24 data ResolvedExport = ResolvedExport
     25   { resolvedExportSourceName :: T.Text
     26   , resolvedExportLocalName  :: String
     27   , resolvedExportObject     :: ObjectRef
     28   , resolvedExportAbi        :: T.Text
     29   , resolvedExportContract   :: Maybe ObjectRef
     30   , resolvedExportTerm       :: T
     31   } deriving (Show, Eq)
     32 
     33 data ResolvedModule = ResolvedModule
     34   { resolvedModuleTarget    :: String
     35   , resolvedModuleNamespace :: String
     36   , resolvedModuleManifest  :: ObjectHash
     37   , resolvedModuleExports   :: [ResolvedExport]
     38   } deriving (Show, Eq)
     39 
     40 resolveModuleImports :: ObjectResolver -> [TricuAST] -> IO ([ResolvedModule], [TricuAST])
     41 resolveModuleImports resolver asts = do
     42   let (imports, nonImports) = foldr splitImport ([], []) asts
     43   modules <- mapM (uncurry (resolveModuleImport resolver)) imports
     44   return (modules, nonImports)
     45   where
     46     splitImport (SImport target namespace) (is, rest) = ((target, namespace) : is, rest)
     47     splitImport ast (is, rest) = (is, ast : rest)
     48 
     49 resolveModuleImport :: ObjectResolver -> String -> String -> IO ResolvedModule
     50 resolveModuleImport resolver moduleTarget namespace =
     51   resolveModuleImportSelecting resolver Nothing moduleTarget namespace
     52 
     53 resolveModuleImportSelecting :: ObjectResolver -> Maybe (Set.Set T.Text) -> String -> String -> IO ResolvedModule
     54 resolveModuleImportSelecting resolver selected moduleTarget namespace = do
     55   manifestHash <- resolveModuleManifestHash resolver moduleTarget
     56   mManifest <- resolveManifest resolver manifestHash
     57   manifest <- case mManifest of
     58     Nothing -> errorWithoutStackTrace $
     59       "Module import failed for " ++ show moduleTarget
     60       ++ " as " ++ show namespace
     61       ++ ": manifest object not found (kind " ++ T.unpack (unDomain manifestDomain)
     62       ++ ", hash " ++ T.unpack manifestHash ++ ")"
     63     Just value -> return value
     64   let wantedExports = case selected of
     65         Nothing -> moduleManifestExports manifest
     66         Just names -> filter (\ex -> moduleExportName ex `Set.member` names) (moduleManifestExports manifest)
     67   exports <- mapM (resolveModuleExport resolver localNamespace) wantedExports
     68   return ResolvedModule
     69     { resolvedModuleTarget = moduleTarget
     70     , resolvedModuleNamespace = namespace
     71     , resolvedModuleManifest = manifestHash
     72     , resolvedModuleExports = exports
     73     }
     74   where
     75     localNamespace = if namespace == "!Local" then "" else namespace
     76 
     77 resolveModuleExport :: ObjectResolver -> String -> ModuleExport -> IO ResolvedExport
     78 resolveModuleExport resolver namespace ex = do
     79   let ref = moduleExportObject ex
     80       sourceName = moduleExportName ex
     81   term <- resolveExportTerm resolver sourceName ref
     82   return ResolvedExport
     83         { resolvedExportSourceName = sourceName
     84         , resolvedExportLocalName = nsVariable namespace (T.unpack sourceName)
     85         , resolvedExportObject = ref
     86         , resolvedExportAbi = moduleExportAbi ex
     87         , resolvedExportTerm = term
     88         }
     89 
     90 resolveExportTerm :: ObjectResolver -> T.Text -> ObjectRef -> IO T
     91 resolveExportTerm resolver sourceName ref
     92   | objectRefKind ref == unDomain treeTermDomain = do
     93       bytes <- requireObject
     94       case decodeTreeTerm bytes of
     95         Left err -> errorWithoutStackTrace $
     96           "Module export " ++ show (T.unpack sourceName)
     97           ++ " references invalid tree term " ++ T.unpack (objectRefHash ref)
     98           ++ ": " ++ err
     99         Right term -> return term
    100   | otherwise = errorWithoutStackTrace $
    101       "Module export " ++ show (T.unpack sourceName)
    102       ++ " has unsupported object kind " ++ show (T.unpack (objectRefKind ref))
    103       ++ "; expected " ++ show (T.unpack (unDomain treeTermDomain))
    104   where
    105     requireObject = do
    106       mBytes <- resolverObject resolver ref
    107       case mBytes of
    108         Just bytes -> return bytes
    109         Nothing -> errorWithoutStackTrace $
    110           "Module export " ++ show (T.unpack sourceName)
    111           ++ " references missing tree term " ++ T.unpack (objectRefHash ref)
    112           ++ " (kind " ++ T.unpack (objectRefKind ref) ++ ")"
    113 
    114 resolvedModulesEnv :: [ResolvedModule] -> Env
    115 resolvedModulesEnv modules = Map.fromList
    116   [ (resolvedExportLocalName ex, resolvedExportTerm ex)
    117   | m <- modules
    118   , ex <- resolvedModuleExports m
    119   ]
    120 
    121 resolveModuleManifestHash :: ObjectResolver -> String -> IO ObjectHash
    122 resolveModuleManifestHash resolver moduleTarget = do
    123   mAlias <- resolverAlias resolver ModuleAlias (T.pack moduleTarget)
    124   case mAlias of
    125     Just ref ->
    126       if objectRefKind ref == unDomain manifestDomain
    127         then return (objectRefHash ref)
    128         else errorWithoutStackTrace $
    129           "Module alias " ++ show moduleTarget
    130           ++ " points at unsupported object kind " ++ show (T.unpack (objectRefKind ref))
    131           ++ "; expected " ++ show (T.unpack (unDomain manifestDomain))
    132           ++ " (hash " ++ T.unpack (objectRefHash ref) ++ ")"
    133     Nothing ->
    134       case textToHashBytes (T.pack moduleTarget) of
    135         Right _ -> return (T.pack moduleTarget)
    136         Left _ -> errorWithoutStackTrace $
    137           "Module alias not found: " ++ show moduleTarget
    138           ++ "; add it to tricu.workspace or write a ModuleAlias, or import by manifest hash"
    139 
    140 nsVariable :: String -> String -> String
    141 nsVariable "" name = name
    142 nsVariable moduleName name = moduleName ++ "." ++ name