Issue27.hs

{-# LANGUAGE GADTs, ImplicitParams, MultiParamTypeClasses #-}
module Regression.Issue27 where

import Prelude hiding (pure, (*>))

import Test.Tasty
import Test.Tasty.HUnit

import Parsley.Internal
import Parsley.Internal.Core.CombinatorAST (Parser(unParser), Combinator)
import Parsley.Internal.Common (Fix(In), Fix4(In4), cata, (\/))
import Parsley.Internal.Backend.CodeGenerator (codeGen)
import Parsley.Internal.Backend.Machine.LetBindings (Binding, body)
import Parsley.Internal.Backend.Machine.Types.Coins (willConsume)
import Parsley.Internal.Backend.Machine.Instructions
import Parsley.Internal.Frontend.Analysis.Cut (cutAnalysis)

import qualified Data.Set as Set (empty)
import qualified Parsley.Internal.Opt   as Opt

import Parsley.Internal.Verbose
--instance {-# INCOHERENT #-} Trace where trace = const id

-- Hand optimised version of string, so we don't have to run the frontend
string :: String -> Parser String
string str = foldr (\c p -> satisfy (EQ_H (LIFTED c)) *> p) (pure (LIFTED str)) str

-- No registers allowed!
toAST :: Parser a -> Fix Combinator a
toAST = cata (In \/ undefined) . unParser

codeGen' :: Fix Combinator a -> Binding o a a
codeGen' p = let ?flags = Opt.fast in body (codeGen Nothing p Set.empty 0)

leadingCoinsUnderCatch :: Fix4 (Instr o) xs n r a -> Maybe Int
leadingCoinsUnderCatch (In4 (Catch (In4 (MetaInstr (AddCoins c) _)) _)) = Just (willConsume c)
leadingCoinsUnderCatch _ = Nothing

leadingCoins :: Fix4 (Instr o) xs n r a -> Maybe Int
leadingCoins (In4 (MetaInstr (AddCoins c) _)) = Just (willConsume c)
leadingCoins _ = Nothing

{- Example 1 -}
desc1 = "under outmost try max 1 coins should be factored without inner try"

ex1_p :: Fix Combinator String
ex1_p = toAST $ try $ string "123" <|> string "45"

test1 :: Assertion
test1 = let coins = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex1_p))
        in (coins `elem` [Just 1, Nothing]) @? "expected 0 or 1 leading coins, got " ++ show coins

{- Example 2 -}
desc2 = "under outermost try 2 coins should be factored with inner try"

ex2_p :: Fix Combinator String
ex2_p = toAST $ try $ try (string "123") <|> string "45"

test2 :: Assertion
test2 = leadingCoins (codeGen' (cutAnalysis ex2_p)) @?= Just 2

{- Example 3 -}
desc3 = "max 1 coins should be factored without try"

ex3_p :: Fix Combinator String
ex3_p = toAST $ string "123" <|> string "45"

test3 :: Assertion
test3 = let coins = leadingCoins (codeGen' (cutAnalysis ex3_p))
        in (coins `elem` [Just 1, Nothing]) @? "expected 0 or 1 leading coins, got " ++ show coins

{- Example 4 -}
desc4 = "max 1 coins should be factored with no outer-most try"

ex4_p :: Fix Combinator String
ex4_p = toAST $ try (string "123") <|> try (string "45")

test4 :: Assertion
test4 = let coins = leadingCoins (codeGen' (cutAnalysis ex4_p))
        in (coins `elem` [Just 1, Nothing]) @? "expected 0 or 1 leading coins, got " ++ show coins

{- Example 5 -}
desc5 = ""

ex5_p :: Fix Combinator String
ex5_p = toAST $ (string "a" <|> pure (LIFTED "")) *> string "1234"

test5 :: Assertion
test5 = let coins = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex5_p))
        in (coins `elem` [Just 1, Nothing]) @? "expected 0 or 1 leading coins, got " ++ show coins

{- Example 6 -}
desc6 = ""

ex6_p :: Fix Combinator String
ex6_p = toAST $ (string "abc" <|> string "def") *> string "123"

test6 :: Assertion
test6 = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex6_p)) @?= Nothing

{- Example 7 -}
desc7 = ""

ex7_p :: Fix Combinator String
ex7_p = toAST $ (string "abc" <|> string "123") *> string "..." <|> string "def"

test7 :: Assertion
test7 = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex7_p)) @?= Nothing

{- Example 8 -}
desc8 = ""

ex8_p :: Fix Combinator String
ex8_p = toAST $ (try (string "abc") <|> string "ade") *> string "..." <|> string "def"

test8 :: Assertion
test8 = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex8_p)) @?= Nothing

tests :: TestTree
tests = testGroup "#27 Input checks in `Frontend` and `Backend` are not properly respecting cuts"
  [ testCase desc1 test1
  , testCase desc2 test2
  --, testCase desc3 test3
  --, testCase desc4 test4
  , testCase desc5 test5
  , testCase desc6 test6
  , testCase desc7 test7
  , testCase desc8 test8
  ]