tricu

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

Resolver.hs (6148B)

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