NameIndexUnit.hs (3440B)
1 -- Independent corpus and complete-result/demand comparisons for the selected module compiler. 2 module Main where 3 import Runtime 4 import Wire 5 import TreeObservation 6 import ContentStore.Indexed(encodeIndexedTree) 7 import qualified Data.ByteString as B 8 import qualified Data.Text as Text 9 import qualified Data.Vector as V 10 import qualified Data.Map.Strict as M 11 import Control.Monad 12 import Control.Exception 13 import Data.List(isInfixOf) 14 import System.Environment 15 load p=do 16 b<-B.readFile p >>= either fail pure . decodeBundle 17 either fail pure(verifyBundle b) 18 let ns=reconstructBundleTerms(bundleNodes b) 19 pure(M.fromList[(Text.unpack(exportName e),ns V.! fromIntegral(exportRoot e))|e<-manifestExports(bundleManifest b)]) 20 fstT(Fork a _)=a 21 fstT _=error "pair" 22 sndT(Fork _ b)=b 23 sndT _=error "pair" 24 list=either error id.toList 25 str=either error id.toString 26 project (Fork status (Fork value _))=case status of 27 Leaf->Fork Leaf(Fork value Leaf) 28 Stem Leaf->case lookup "main" [(str(fstT binding),sndT binding)|binding<-list value] of 29 Just main->Fork(Stem Leaf)(Fork main Leaf) 30 Nothing->error "main absent" 31 _->error "status" 32 project _=error "result" 33 main=do 34 [fixture,adapter,corpus]<-getArgs 35 original<-load fixture;candidate<-load adapter;golden<-load corpus 36 let ref=original M.!"source_unit.compileStableModuleDefinitions" 37 cand=candidate M.!"compileStableModuleDefinitions" 38 rows=list(golden M.!"fixtures") 39 forM_ rows $ \row->do 40 let label=str(fstT row);rest=sndT row;truth=fstT rest;input=sndT rest 41 environment=fstT input;source=fstT(sndT input);expected=sndT(sndT input) 42 a=apply(apply ref environment)source;b=apply(apply cand environment)source 43 ab<-encodeIndexedTree a;bb<-encodeIndexedTree b 44 unless(ab==bb)(fail(label++": complete compiler result differs")) 45 actual<-encodeIndexedTree(project b);target<-encodeIndexedTree expected 46 unless((actual==target)==(truth/=Leaf))(fail(label++": independent source outcome differs")) 47 putStrLn("PASS "++label) 48 let poison=error "opaque environment poison"::T 49 env xs=ofList[Fork(ofString n)v|(n,v)<-xs] 50 controls=[("duplicate external",env[("outside",ofNumber 23),("outside",ofNumber 24)],"main = outside"), 51 ("unused poison",env[("unused",poison),("outside",ofNumber 23)],"main = outside"), 52 ("unused selected namespace",env[("outside",poison)],"main = 23"), 53 ("shadow before missing",env[("main",poison)],"main = missing"), 54 ("parse before environment",poison,"main = (")] 55 forM_ controls $ \(label,environment,source)->do 56 let a=apply(apply ref environment)(ofString source);b=apply(apply cand environment)(ofString source) 57 ab<-encodeIndexedTree a;bb<-encodeIndexedTree b 58 unless(ab==bb)(fail(label++": full result/demand mismatch")) 59 when(label `elem` ["duplicate external","unused poison","unused selected namespace"]) $ 60 unless(project b==Fork(Stem Leaf)(Fork(ofNumber 23)Leaf))(fail(label++": expected 23")) 61 putStrLn("PASS "++label) 62 forM_ [ref,cand] $ \compiler->do 63 let badTail=Fork(Fork(ofString "outside")(ofNumber 23))poison 64 answer=apply(apply compiler badTail)(ofString "main = outside") 65 failed<-try(encodeIndexedTree answer)::IO(Either SomeException B.ByteString) 66 case failed of 67 Left e | "opaque environment poison" `isInfixOf` displayException e ->pure() 68 _ ->fail "module shadow scan demand changed" 69 putStrLn("PASS "++show(length rows)++" complete-result comparisons and independent outcomes")