tricu

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

NameIndex.hs (3355B)

      1 -- Complete-result host model; partial inputs below are demand controls, not a totality proof.
      2 module Main where
      3 import Runtime
      4 import Wire
      5 import TreeObservation
      6 import qualified Data.ByteString as B
      7 import qualified Data.Text as Text
      8 import qualified Data.Vector as V
      9 import qualified Data.Map.Strict as M
     10 import Control.Monad
     11 import Control.Exception
     12 import System.Environment
     13 import Data.List (isInfixOf)
     14 load path = do
     15  b<-B.readFile path >>= either fail pure . decodeBundle
     16  either fail pure(verifyBundle b)
     17  let ns=reconstructBundleTerms(bundleNodes b)
     18  pure(M.fromList[(Text.unpack(exportName e),ns V.! fromIntegral(exportRoot e))|e<-manifestExports(bundleManifest b)])
     19 keys 0=[Leaf]
     20 keys n=Leaf:map Stem(keys(n-1))++[Fork a b|a<-keys(n-1),b<-keys(n-1)]
     21 main=do
     22  [path]<-getArgs;c<-load path
     23  let build=c M.!"sourceIndexBuild";get=c M.!"sourceIndexGet";put=c M.!"sourceIndexPut"
     24      fetch index key=apply(apply get index)key
     25      entries xs=ofList[Fork k v|(k,v)<-xs]
     26      ks=keys 3++map(ofString.show)[0..100::Int]++map ofString ["","a","aa","aaa","a.b","a?","a%","A","alpha.beta","alpha.better"]
     27      bs=[(k,ofNumber(toInteger i))|(i,k)<-zip[0..]ks]
     28      index=apply build(entries(bs++reverse bs))
     29  forM_ ks $ \k -> do
     30   let actual=fetch index k;expected=maybe Leaf Stem(lookup k bs)
     31   forceTreeShared actual;unless(actual==expected)(fail "first-binding mismatch")
     32  let overwritten=apply(apply(apply put (ofString "new"))(ofNumber 77))index
     33  forM_ [(ofString "new",Stem(ofNumber 77)),(ofString "missing",Leaf)] $ \(k,e)->do
     34   let a=fetch overwritten k
     35   forceTreeShared a
     36   unless(a==e)(fail "put/miss mismatch")
     37  let updated=apply(apply(apply put Leaf)(ofNumber 999))index
     38  forM_ [(fetch updated Leaf,Stem(ofNumber 999)),(fetch index Leaf,Stem(ofNumber 0))] $ \(a,e)->do
     39   forceTreeShared a;unless(a==e)(fail "persistent overwrite")
     40  let poison=error "poison forced"::T
     41      present (Stem _)=True;present _=False
     42      controls=[ ("opaque hit",fetch(apply build(entries[(Leaf,poison)]))Leaf,True)
     43               , ("opaque miss",fetch(apply build(entries[(Leaf,poison)]))(Stem Leaf),False)
     44               , ("first hit before bad key",fetch(apply build(entries[(Leaf,Leaf),(poison,poison)]))Leaf,True)
     45               , ("first hit before bad tail",fetch(apply build(Fork(Fork Leaf Leaf)poison))Leaf,True)
     46               , ("empty ignores query",fetch Leaf poison,False)
     47               , ("mismatch ignores query child",fetch(apply build(entries[(Leaf,poison)]))(Stem poison),False)
     48               , ("mismatched stem child",fetch(apply build(entries[(Stem poison,poison),(Leaf,Leaf)]))Leaf,True)
     49               , ("mismatched left ignores right",fetch(apply build(entries[(Fork Leaf poison,poison),(Fork(Stem Leaf)Leaf,Leaf)]))(Fork(Stem Leaf)Leaf),True)]
     50  forM_ controls $ \(label,a,e)->do
     51   actual<-evaluate(present a);unless(actual==e)(fail label)
     52  forM_ [fetch(apply build(entries[(poison,Leaf),(Leaf,Leaf)]))Leaf,
     53         fetch(apply build(entries[(Fork poison Leaf,Leaf),(Fork Leaf Leaf,Leaf)]))(Fork Leaf Leaf)] $ \a->do
     54   failure<-try(evaluate(present a))::IO(Either SomeException Bool)
     55   case failure of
     56    Left e | "poison forced" `isInfixOf` displayException e -> pure()
     57    _ -> fail "earlier poisoned key incorrectly bypassed"
     58  putStrLn("PASS "++show(length ks)++" complete lookups, put/miss, "++show(length controls)++" demand controls")