tricu

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

BrowserModules.hs (4347B)

      1 -- The source grammar/shape checks and body compiler remain portable trees.
      2 -- This adapter hydrates verified closed exports and projects the native-parsed
      3 -- public interface without publishing/hashing (and thereby forcing) new trees.
      4 module BrowserModules where
      5 import Runtime.Tree
      6 import Runtime.Value
      7 import qualified CompilerProbe as C
      8 import Control.Monad (unless, foldM)
      9 import Data.List (nub)
     10 import qualified BrowserRuntime as R
     11 
     12 type Bindings = [(String,T)]
     13 data Stage = Stage { body :: String, uses :: [(String,String)], exports :: [(String,String)] }
     14 
     15 helper :: Bindings -> String -> [T] -> T
     16 helper library name args = case lookup ("source_module." ++ name) library of
     17   Nothing -> error "Missing native module compiler helper"
     18   Just f -> foldl apply f args
     19 
     20 result :: Bool -> T -> IO T
     21 result diagnostic tree = case C.pair tree of
     22   (Stem Leaf,payload) -> pure (fst (C.pair payload))
     23   (Leaf,payload) -> fail (if diagnostic then C.diagnostic payload else C.text (fst (C.pair payload)))
     24   _ -> fail "Invalid native module result"
     25 
     26 boundedList :: Int -> T -> IO [T]
     27 boundedList limit tree = do
     28   values <- either fail pure (toList tree)
     29   unless (length (take (limit+1) values) <= limit) (fail "Module list limit exceeded")
     30   pure values
     31 
     32 stage :: Bindings -> String -> IO Stage
     33 stage library source = do
     34   unless (not (null source) && length source <= 16384) (fail "source scalar limit exceeded")
     35   parsed <- result True (helper library "sourceModuleHeaderStage" [ofString source])
     36   let (edges,rest) = C.pair parsed
     37       (imports,tail1) = C.pair rest
     38       (selected,masked) = C.pair tail1
     39   dependencies <- boundedList 16384 edges
     40   unless (null dependencies) (fail "Browser modules require manifest hashes; workspace and build-only sources are unavailable")
     41   let shapes name rows = do
     42         values <- boundedList 16384 rows
     43         mapM (\row -> do
     44           spec <- result False (helper library name [row])
     45           let (a,b) = C.pair spec
     46           let left = C.text a; right = C.text b
     47           unless (length left <= 128 && length right <= 128) (fail "Module header name limit exceeded")
     48           pure (left,right)) values
     49   us <- shapes "sourceModuleUseShape" imports
     50   es <- shapes "sourceModuleExportShape" selected
     51   pure (Stage (C.text masked) us es)
     52 
     53 native :: Stage -> Bool
     54 native s = not (null (uses s) && null (exports s))
     55 
     56 stageJSON :: Stage -> R.J
     57 stageJSON s = R.O [("body",R.S (body s)),("imports",pairs (uses s)),("exports",pairs (exports s)),("native",R.B (native s))]
     58   where pairs rows = R.A [R.A [R.S a,R.S b] | (a,b) <- rows]
     59 
     60 compile :: Bindings -> T -> Stage -> [(String,Bindings)] -> IO (Bindings,Bindings)
     61 compile library compiler s modules = do
     62   let dependency ref = maybe (fail "Missing module dependency") pure (lookup ref modules)
     63       extend env (ref,alias) = do
     64         entries <- dependency ref
     65         foldM (\bindings (name,tree) -> do
     66           let qualified = C.text (helper library "sourceModuleQualified" [ofString alias,ofString name])
     67           unless (length qualified <= 4096 && not (qualified `elem` map fst bindings)) (fail "duplicate imported name")
     68           unless (length bindings < 4096) (fail "Module binding limit exceeded")
     69           pure (bindings ++ [(qualified,tree)])) env entries
     70   imported <- foldM extend [] (uses s)
     71   let env = ofList [Fork (ofString name) tree | (name,tree) <- imported]
     72   locals <- either fail pure (C.definitions (C.compile compiler env (ofString (body s))))
     73   let names = map fst (take 17 locals)
     74   unless (length names <= 16 && all (\n -> not (null n) && length n <= 128) names && length (nub names) == length names)
     75     (fail "invalid compiler definition names")
     76   let add selected (name,tree) = do
     77         unless (not (name `elem` map fst selected)) (fail "duplicate export")
     78         unless (length selected < 4096) (fail "Module export limit exceeded")
     79         pure (selected ++ [(name,tree)])
     80       select selected (name,ref)
     81         | name == "from" = dependency ref >>= foldM add selected
     82         | name == "*" = foldM add selected locals
     83         | otherwise = case lookup name locals of
     84             Nothing -> fail "undeclared local export"
     85             Just tree -> add selected (name,tree)
     86   public <- foldM select [] (exports s)
     87   unless (not (null public)) (fail "module requires an export")
     88   pure (public,locals ++ imported)