ParserValueTests.hs (18168B)
1 -- Parser protocols tested by applying authenticated trees to explicit values. 2 -- Expected replies are independently constructed, including rest/progress flags. 3 module ParserValueTests (portableParserTests, binaryParserTests) where 4 5 import Runtime 6 import ContentStore.Arboricx (encodeTreeTerm) 7 import Control.Exception (evaluate) 8 import Control.Monad (forM_) 9 import qualified Data.ByteString as BS 10 import qualified Data.Map as Map 11 import Test.Tasty 12 import Test.Tasty.HUnit 13 14 trueT, falseT :: T 15 trueT = Stem Leaf 16 falseT = Leaf 17 pairT :: T -> T -> T 18 pairT = Fork 19 bytesT :: [Integer] -> T 20 bytesT = ofList . map ofNumber 21 parserOk, parserErr :: T -> T -> T 22 parserOk value rest = Fork trueT (Fork value rest) 23 parserErr code rest = Fork falseT (Fork code rest) 24 25 portableReply :: Bool -> T -> T -> Bool -> Bool -> T 26 portableReply success payload rest consumed committed = 27 pairT (if success then trueT else falseT) 28 (pairT payload (pairT rest (pairT 29 (if consumed then trueT else falseT) 30 (if committed then trueT else falseT)))) 31 32 portableDiagnostic :: T -> T -> T -> T -> T -> T 33 portableDiagnostic code expected found location contexts = 34 pairT code (pairT expected (pairT found (pairT location contexts))) 35 36 portableCode :: Integer -> T 37 portableCode code = portableDiagnostic (ofNumber code) Leaf Leaf Leaf Leaf 38 39 portableFound :: Integer -> T -> T -> T 40 portableFound code expected found = 41 portableDiagnostic (ofNumber code) expected found Leaf Leaf 42 43 portableParserTests :: Env -> Env -> TestTree 44 portableParserTests parser base = testGroup "Portable parser protocol" 45 [ testCase "constructed reply matcher ignores poisoned fields and unselected handlers" $ do 46 let matcher = parser Map.! "parserMatchReply" 47 constant n = iterate (Fork Leaf) (ofNumber n) !! 4 48 failed = constant (11 :: Integer) 49 succeeded = constant (22 :: Integer) 50 poison = error "parser matcher demanded an ignored field/handler" 51 _ <- evaluate (BS.length (encodeTreeTerm matcher)) 52 foldl apply matcher [failed, poison, Fork Leaf poison] @?= ofNumber 11 53 forM_ [Stem Leaf, Fork Leaf Leaf, Stem (Stem Leaf)] $ \status -> 54 foldl apply matcher [poison, succeeded, Fork status poison] @?= ofNumber 22 55 , testCase "pure preserves input" $ 56 check (p "parserPure" [ofNumber 9, bytesT [1, 2]]) 57 (portableReply True (ofNumber 9) (bytesT [1, 2]) False False) 58 , testCase "any consumes one token" $ 59 check (p "parserAny" [bytesT [1, 2]]) 60 (portableReply True (ofNumber 1) (bytesT [2]) True False) 61 , testCase "any reports EOF without consumption" $ 62 check (p "parserAny" [ofList []]) 63 (portableReply False (portableCode 1) (bytesT []) False False) 64 , testCase "satisfy mismatch does not consume" $ 65 check (p "parserExpect" [ofNumber 3, bytesT [1, 2]]) 66 (portableReply False (portableFound 2 (ofNumber 3) (ofNumber 1)) (bytesT [1, 2]) False False) 67 , testCase "sequencing propagates consumption through failure" $ 68 check (p "parserBind" [p "parserAny" [], ignoreFailure7, bytesT [1, 2]]) 69 (portableReply False (portableCode 7) (bytesT [2]) True False) 70 , testCase "alternative does not retry consumed failure" $ 71 check (p "parserOr" [p "parserThen" [p "parserAny" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, Leaf, Leaf]]], p "parserAny" [], bytesT [1, 2]]) 72 (portableReply False (portableCode 7) (bytesT [2]) True False) 73 , testCase "alternative retries unconsumed failure" $ 74 check (p "parserOr" [p "parserExpect" [ofNumber 3], p "parserAny" [], bytesT [1, 2]]) 75 (portableReply True (ofNumber 1) (bytesT [2]) True False) 76 , testCase "commit without consumption prevents fallback" $ 77 check (p "parserOr" [p "parserThen" [p "parserCommit" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, Leaf, Leaf]]], p "parserAny" [], bytesT [1, 2]]) 78 (portableReply False (portableCode 7) (bytesT [1, 2]) False True) 79 , testCase "successful commit propagates through sequencing" $ 80 check (p "parserThen" [p "parserCommit" [], p "parserAny" [], bytesT [1, 2]]) 81 (portableReply True (ofNumber 1) (bytesT [2]) True True) 82 , testCase "attempt leaves success flags unchanged" $ 83 check (p "parserAttempt" [p "parserThen" [p "parserCommit" [], p "parserAny" []], bytesT [1, 2]]) 84 (portableReply True (ofNumber 1) (bytesT [2]) True True) 85 , testCase "attempt rolls back consumed and committed failure" $ 86 check (p "parserOr" [p "parserAttempt" [p "parserThen" [p "parserAny" [], p "parserThen" [p "parserCommit" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, Leaf, Leaf]]]]], p "parserAny" [], bytesT [1, 2]]) 87 (portableReply True (ofNumber 1) (bytesT [2]) True False) 88 , testCase "attempt cannot clear prior outer commitment" $ 89 check (p "parserThen" [p "parserCommit" [], p "parserAttempt" [p "parserThen" [p "parserAny" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, Leaf, Leaf]]]], bytesT [1, 2]]) 90 (portableReply False (portableCode 7) (bytesT [1, 2]) False True) 91 , testCase "map preserves flags" $ 92 check (p "parserMap" [pairWithLeaf, p "parserAny" [], bytesT [1, 2]]) 93 (portableReply True (pairT (ofNumber 1) Leaf) (bytesT [2]) True False) 94 , testCase "peek leaves stream and flags unchanged" $ 95 check (p "parserPeek" [bytesT [1, 2]]) 96 (portableReply True (ofNumber 1) (bytesT [1, 2]) False False) 97 , testCase "peek reports EOF without consumption" $ 98 check (p "parserPeek" [ofList []]) 99 (portableReply False (portableCode 1) (bytesT []) False False) 100 , testCase "apply sequences a parsed function and argument" $ 101 check (p "parserApply" [p "parserPure" [pairWithLeaf], p "parserAny" [], bytesT [1, 2]]) 102 (portableReply True (pairT (ofNumber 1) Leaf) (bytesT [2]) True False) 103 , testCase "EOF succeeds only at end" $ do 104 check (p "parserEof" [ofList []]) 105 (portableReply True Leaf (bytesT []) False False) 106 check (p "parserEof" [bytesT [1]]) 107 (portableReply False (portableFound 2 Leaf (ofNumber 1)) (bytesT [1]) False False) 108 , testCase "optional restores unmatched input" $ 109 check (p "parserOptional" [p "parserExpect" [ofNumber 3], bytesT [1]]) 110 (portableReply True Leaf (bytesT [1]) False False) 111 , testCase "optional does not hide committed failure" $ 112 check (p "parserOptional" [p "parserThen" [p "parserCommit" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, Leaf, Leaf]]], bytesT [1]]) 113 (portableReply False (portableCode 7) (bytesT [1]) False True) 114 , testCase "many stops without consuming the failing token" $ 115 check (p "parserMany" [p "parserExpect" [ofNumber 1], bytesT [1, 1, 2]]) 116 (portableReply True (bytesT [1, 1]) (bytesT [2]) True False) 117 , testCase "many at EOF" $ 118 check (p "parserMany" [p "parserAny" [], ofList []]) 119 (portableReply True (bytesT []) (bytesT []) False False) 120 , testCase "some at EOF" $ 121 check (p "parserSome" [p "parserAny" [], ofList []]) 122 (portableReply False (portableCode 1) (bytesT []) False False) 123 , testCase "some parses nonempty prefix" $ 124 check (p "parserSome" [p "parserExpect" [ofNumber 1], bytesT [1, 2]]) 125 (portableReply True (bytesT [1]) (bytesT [2]) True False) 126 , testCase "many rejects zero-width success, including commitment" $ do 127 check (p "parserMany" [p "parserPure" [ofNumber 9], bytesT [1]]) 128 (portableReply False (portableCode 3) (bytesT [1]) False False) 129 check (p "parserMany" [p "parserCommit" [], bytesT [1]]) 130 (portableReply False (portableCode 3) (bytesT [1]) False True) 131 , testCase "some rejects zero-width success" $ 132 check (p "parserSome" [p "parserPure" [ofNumber 9], bytesT [1]]) 133 (portableReply False (portableCode 3) (bytesT [1]) False False) 134 , testCase "many propagates consumed failure" $ 135 check (p "parserMany" [p "parserThen" [p "parserAny" [], p "parserExpect" [ofNumber 7]], bytesT [1, 2]]) 136 (portableReply False (portableFound 2 (ofNumber 7) (ofNumber 2)) (bytesT [2]) True False) 137 , testCase "many propagates committed failure" $ 138 check (p "parserMany" [p "parserThen" [p "parserCommit" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, Leaf, Leaf]]], bytesT [1]]) 139 (portableReply False (portableCode 7) (bytesT [1]) False True) 140 , testCase "many preserves prior progress when later iteration commits" $ 141 check (p "parserMany" [p "parserOr" [p "parserExpect" [ofNumber 1], p "parserThen" [p "parserCommit" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, Leaf, Leaf]]]], bytesT [1, 2]]) 142 (portableReply False (portableCode 7) (bytesT [2]) True True) 143 , testCase "before discards second value but propagates flags" $ 144 check (p "parserBefore" [p "parserAny" [], p "parserCommit" [], bytesT [1]]) 145 (portableReply True (ofNumber 1) (bytesT []) True True) 146 , testCase "takeWhile consumes a prefix" $ 147 check (p "parserTakeWhile" [equalsOne, bytesT [1, 1, 2]]) 148 (portableReply True (bytesT [1, 1]) (bytesT [2]) True False) 149 , testCase "takeWhile1 requires a match" $ 150 check (p "parserTakeWhile1" [equalsOne, bytesT [2]]) 151 (portableReply False (portableFound 2 Leaf (ofNumber 2)) (bytesT [2]) False False) 152 , testCase "takeWhile handles a longer finite stream" $ 153 check (p "parserTakeWhile" [equalsOne, bytesT (replicate 64 1 ++ [2])]) 154 (portableReply True (bytesT (replicate 64 1)) (bytesT [2]) True False) 155 , testCase "expected token survives EOF" $ 156 check (p "parserExpect" [ofNumber 4, ofList []]) 157 (portableReply False (portableFound 1 (ofNumber 4) Leaf) (bytesT []) False False) 158 , testCase "label and nested contexts preserve found and location" $ 159 check (p "parserContext" [ofNumber 4, p "parserContext" [ofNumber 5, p "parserLabel" [ofNumber 8, p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, ofNumber 6, ofNumber 9, Leaf]]]], ofList []]) 160 (portableReply False 161 (portableDiagnostic (ofNumber 7) (ofNumber 8) (ofNumber 6) 162 (ofNumber 9) (bytesT [4, 5])) (bytesT []) False False) 163 , testCase "attempt preserves diagnostic location on rollback" $ 164 check (p "parserAttempt" [p "parserThen" [p "parserAny" [], p "parserFailure" [p "parserDiagnostic" [ofNumber 7, Leaf, Leaf, ofNumber 9, Leaf]]], bytesT [1]]) 165 (portableReply False 166 (portableDiagnostic (ofNumber 7) Leaf Leaf (ofNumber 9) Leaf) 167 (bytesT [1]) False False) 168 , testCase "between consumes both delimiters" $ 169 check (p "parserBetween" [p "parserExpect" [ofNumber 1], p "parserAny" [], p "parserExpect" [ofNumber 3], bytesT [1, 2, 3, 4]]) 170 (portableReply True (ofNumber 2) (bytesT [4]) True False) 171 , testCase "sepBy accepts empty list" $ 172 check (p "parserSepBy" [p "parserExpect" [ofNumber 1], p "parserExpect" [ofNumber 2], bytesT [3]]) 173 (portableReply True (bytesT []) (bytesT [3]) False False) 174 , testCase "sepBy1 parses separated elements" $ 175 check (p "parserSepBy1" [p "parserExpect" [ofNumber 1], p "parserExpect" [ofNumber 2], bytesT [1, 2, 1, 3]]) 176 (portableReply True (bytesT [1, 1]) (bytesT [3]) True False) 177 , testCase "sepBy rejects trailing separator" $ 178 check (p "parserSepBy" [p "parserExpect" [ofNumber 1], p "parserExpect" [ofNumber 2], bytesT [1, 2]]) 179 (portableReply False (portableFound 1 (ofNumber 1) Leaf) (bytesT []) True False) 180 , testCase "sepBy rejects zero-width element and separator" $ 181 check (p "parserSepBy" [p "parserPure" [ofNumber 1], p "parserPure" [ofNumber 2], ofList []]) 182 (portableReply False (portableCode 3) (bytesT []) False False) 183 ] 184 where 185 check actual expected = actual @?= expected 186 p name = foldl apply (parser Map.! name) 187 ignoreFailure7 = Fork Leaf (p "parserFailure" [portableCode 7]) 188 equalsOne = apply (base Map.! "equal?") (ofNumber 1) 189 -- S t (K t): x -> Fork x Leaf, independent of a source frontend. 190 pairWithLeaf = Fork (Stem Leaf) (Fork Leaf Leaf) 191 192 binaryParserTests :: Env -> Env -> Env -> TestTree 193 binaryParserTests binary parser base = testGroup "Binary Parser Tests" 194 [ testCase "binary support exposes Result byte reader" $ do 195 Map.member "readU8" binary @?= True 196 b "readU8" [bytesT [7]] @?= 197 parserOk (ofNumber 7) Leaf 198 , testCase "generic byte reader records progress and EOF" $ do 199 p "parserAny" [bytesT [7, 8]] @?= 200 portableReply True (ofNumber 7) (bytesT [8]) True False 201 p "parserAny" [ofList []] @?= 202 portableReply False (portableCode 1) Leaf False False 203 , testCase "generic expect records mismatch without consuming" $ do 204 p "parserExpect" [ofNumber 7, bytesT [8]] @?= 205 portableReply False 206 (portableFound 2 (ofNumber 7) (ofNumber 8)) 207 (bytesT [8]) False False 208 p "parserExpect" [ofNumber 7, ofList []] @?= 209 portableReply False 210 (portableDiagnostic (ofNumber 1) (ofNumber 7) Leaf Leaf Leaf) 211 Leaf False False 212 , testCase "byte expectations retain numeric codes and rollback" $ do 213 let check input expected = 214 input @?= expected 215 check (b "readU8" [ofList []]) (parserErr (ofNumber 1) Leaf) 216 check (b "peekU8" [ofList []]) (parserErr (ofNumber 1) Leaf) 217 check (b "expectU8" [ofNumber 7, bytesT [8, 9]]) 218 (parserErr (ofNumber 3) (bytesT [8, 9])) 219 check (b "expectU8" [ofNumber 7, ofList []]) (parserErr (ofNumber 1) Leaf) 220 check (b "expectU8" [ofNumber 7, bytesT [7, 9]]) 221 (parserOk Leaf (bytesT [9])) 222 check (b "expectBytes" [bytesT [104, 105], bytesT [104]]) 223 (parserErr (ofNumber 1) (bytesT [104])) 224 check (b "expectBytes" [bytesT [104, 105], bytesT [104, 99]]) 225 (parserErr (ofNumber 2) (bytesT [104, 99])) 226 check (b "orParser" [b "bindParser" [b "readU8" [], ignoreFailure77], b "readU8" [], bytesT [5, 6]]) 227 (parserOk (ofNumber 5) (bytesT [6])) 228 , testCase "Result rollback and consumption-aware alternatives remain distinct" $ do 229 let input = bytesT [5, 6] 230 failure = p "parserBind" [p "parserAny" [], Fork Leaf (p "parserFailure" [portableCode 77])] 231 b "bindParser" [b "readU8" [], ignoreFailure77, input] @?= 232 parserErr (ofNumber 77) (bytesT [6]) 233 b "orParser" [b "bindParser" [b "readU8" [], ignoreFailure77], b "readU8" [], input] @?= 234 parserOk (ofNumber 5) (bytesT [6]) 235 p "parserOr" [failure, p "parserAny" [], input] @?= 236 portableReply False (portableCode 77) (bytesT [6]) True False 237 , testCase "pureParser succeeds" $ do 238 b "pureParser" [ofNumber 42, bytesT [1, 2]] @?= parserOk (ofNumber 42) (bytesT [1, 2]) 239 240 , testCase "failParser fails" $ do 241 b "failParser" [ofNumber 99, bytesT [1, 2]] @?= parserErr (ofNumber 99) (bytesT [1, 2]) 242 243 , testCase "mapParser transforms value" $ do 244 b "mapParser" [base Map.! "succ", b "readU8" [], bytesT [1, 2]] @?= parserOk (ofNumber 2) (bytesT [2]) 245 246 , testCase "bindParser chains parsers" $ do 247 b "bindParser" [b "readU8" [], ignoreRead, bytesT [1, 2]] @?= parserOk (ofNumber 2) (bytesT []) 248 249 , testCase "thenParser discards first result" $ do 250 b "thenParser" [b "readU8" [], b "readU8" [], bytesT [1, 2]] @?= parserOk (ofNumber 2) (bytesT []) 251 252 , testCase "orParser tries second on first failure" $ do 253 b "orParser" [b "failParser" [ofNumber 1], b "readU8" [], bytesT [5]] @?= parserOk (ofNumber 5) (bytesT []) 254 255 , testCase "orParser returns first on success" $ do 256 b "orParser" [b "readU8" [], b "failParser" [ofNumber 1], bytesT [5]] @?= parserOk (ofNumber 5) (bytesT []) 257 258 , testCase "readWhile consumes matching bytes" $ do 259 b "readWhile" [lessThanThree, bytesT [1, 2, 3, 4]] @?= parserOk (bytesT [1, 2]) (bytesT [3, 4]) 260 261 , testCase "readWhile leaves non-matching byte" $ do 262 b "bindParser" [b "readWhile" [lessThanThree], ignoreRead, bytesT [1, 2, 3]] @?= parserOk (ofNumber 3) (bytesT []) 263 264 , testCase "readUntil stops at matching byte" $ do 265 b "readUntil" [equalsThree, bytesT [1, 2, 3, 4]] @?= parserOk (bytesT [1, 2]) (bytesT [3, 4]) 266 267 , testCase "readRemaining returns all bytes" $ do 268 b "readRemaining" [bytesT [1, 2, 3]] @?= parserOk (bytesT [1, 2, 3]) (bytesT []) 269 270 , testCase "peekU8 does not consume" $ do 271 b "bindParser" [b "peekU8" [], ignoreRead, bytesT [7, 8]] @?= parserOk (ofNumber 7) (bytesT [8]) 272 273 , testCase "peekU8 second read gets same byte" $ do 274 b "bindParser" [b "peekU8" [], capturePeek, bytesT [7]] @?= parserOk (pairT (ofNumber 7) (ofNumber 7)) (bytesT [7]) 275 276 , testCase "eof? succeeds at empty input" $ do 277 b "eof?" [ofList []] @?= parserOk Leaf (bytesT []) 278 279 , testCase "eof? rejects non-empty input and preserves its remainder" $ do 280 -- The old reference uses EOF code 1; current candidate code 2 is checked 281 -- independently by bundle_batch.py, not inferred from this fixture. 282 case b "eof?" [bytesT [1]] of 283 Fork flag (Fork _ rest) -> do 284 flag @?= falseT 285 rest @?= bytesT [1] 286 other -> assertFailure ("Expected failure Result, got " ++ show other) 287 288 , testCase "expectAscii matches string" $ do 289 b "expectAscii" [ofString "hi", bytesT [104, 105, 106]] @?= parserOk Leaf (bytesT [106]) 290 291 , testCase "expectAscii fails on mismatch" $ do 292 b "expectAscii" [ofString "hi", bytesT [104, 99]] @?= parserErr (ofNumber 2) (bytesT [104, 99]) 293 ] 294 where 295 b name = foldl apply (binary Map.! name) 296 p name = foldl apply (parser Map.! name) 297 compose f g = foldl apply (base Map.! "compose") [f, g] 298 ignoreFailure77 = Fork Leaf (b "failParser" [ofNumber 77]) 299 ignoreRead = Fork Leaf (b "readU8" []) 300 -- Canonical numeric predicates; these tests exercise parser consumption. 301 lessThanThree = apply (base Map.! "gt?") (ofNumber 3) 302 equalsThree = apply (base Map.! "equal?") (ofNumber 3) 303 -- x -> bindParser peekU8 (y -> pureParser (Fork x y)). 304 capturePeek = compose (b "bindParser" [b "peekU8" []]) 305 (compose (apply (base Map.! "compose") (b "pureParser" [])) Leaf)