add testcases for -XImpredicativeTypes failures

With -XImpredicativeTypes, the following occurs:

basic_typeclass.i.hs:877:28: error: [GHC-36495]
    • tagToEnum# must appear applied to one value argument
    • In the first argument of ‘(&&)’, namely
        ‘(GHC.Exts.tagToEnum# (offset >=# 0#))’
      In the expression:
        (GHC.Exts.tagToEnum# (offset >=# 0#))
          &&
            let check = alexIndexInt16OffAddr alex_check offset
            in (GHC.Exts.tagToEnum# (check ==# ord_c))
      In the expression:
        if (GHC.Exts.tagToEnum# (offset >=# 0#))
             &&
               let check = alexIndexInt16OffAddr alex_check offset
               in (GHC.Exts.tagToEnum# (check ==# ord_c)) then
            alexIndexInt16OffAddr alex_table offset
        else
            alexIndexInt16OffAddr alex_deflt s
    |
877 |                 new_s = if GTE(offset,ILIT(0))
    |                            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Author: NadiaYvette

alex.cabal

@@ -80,6 +80,7 @@ extra-source-files:
         tests/gscan_typeclass.x
         tests/posn_typeclass.x
         tests/monad_typeclass.x
+        tests/monadic_expr.x
         tests/monad_typeclass_bytestring.x
         tests/monadUserState_typeclass.x
         tests/monadUserState_typeclass_bytestring.x

tests/Makefile

@@ -86,6 +86,7 @@ ifeq "$(GHC_SHIPS_WITH_TEXT)" "yes"
 TEXT_DEP = -package text
 
 TEXT_TESTS = \
+		monadic_expr.x \
 		strict_text_typeclass.x \
 		posn_typeclass_strict_text.x \
 		tokens_monadUserState_strict_text.x
@@ -105,12 +106,15 @@ TEST_ALEX_OPTS=
 %.g.hs : %.x
 	$(ALEX) $(TEST_ALEX_OPTS) -g $< -o $@
 
+%.i.hs : %.x
+	$(ALEX) $(TEST_ALEX_OPTS) -g $< -o $@
+
 %.d.hs : %.x
 	$(ALEX) $(TEST_ALEX_OPTS) --debug $< -o $@
 
-CLEAN_FILES += *.n.hs *.g.hs *.d.hs *.info *.hi *.o *.bin *.exe
+CLEAN_FILES += *.n.hs *.g.hs *.i.hs *.d.hs *.info *.hi *.o *.bin *.exe
 
-TESTS_HS       = $(shell echo $(TESTS) $(TEXT_TESTS) | sed -e 's/\([^\. ]*\)\.\(l\)\{0,1\}x/\1.n.hs \1.g.hs/g')
+TESTS_HS       = $(shell echo $(TESTS) $(TEXT_TESTS) | sed -e 's/\([^\. ]*\)\.\(l\)\{0,1\}x/\1.n.hs \1.g.hs \1.i.hs/g')
 TESTS_HS_DEBUG = $(shell echo $(TESTS) $(TEXT_TESTS) | sed -e 's/\([^\. ]*\)\.\(l\)\{0,1\}x/\1.d.hs/g')
 TESTS_HS_ALL   = $(TESTS_HS) $(TESTS_HS_DEBUG)
 
@@ -122,7 +126,7 @@ ALL_TESTS   = $(BASIC_TESTS) $(DEBUG_TESTS)
 	./$<
 
 %$(HS_PROG_EXT) : %.hs
-	$(HC) $(HC_OPTS) -package array -package bytestring $(TEXT_DEP) $($*_LD_OPTS) $< -o $@
+	$(HC) $(if $(findstring .i.,$@),-XImpredicativeTypes,) $(HC_OPTS) -package array -package bytestring $(TEXT_DEP) $($*_LD_OPTS) $< -o $@
 
 all :: $(ALL_TESTS)
 

tests/monadic_expr.x

@@ -0,0 +1,122 @@
+{
+module Main (main) where
+import {- "containers" -} Data.Set (Set)
+import {- "containers" -} qualified Data.Set as Set
+import {- "text" -} Data.Text (Text)
+import {- "text" -} qualified Data.Text as Text
+import {- "text" -} qualified Data.Text.Read as Text
+import {- "base" -} Control.Arrow hiding (arr)
+import {- "base" -} Control.Monad (forM_, when)
+import {- "base" -} Control.Monad.Fail (MonadFail)
+import {- "base" -} qualified Control.Monad.Fail as Fail (MonadFail (..))
+import {- "base" -} Numeric.Natural
+import {- "base" -} System.Exit
+}
+
+%wrapper "monadUserState-strict-text"
+%token "Token integer"
+%typeclass "Integral integer, Read integer, Show integer"
+
+-- ugh
+$digit = 0-9
+$unidigit = 1-9
+@number = [0] | $unidigit $digit*
+
+tokens :-
+  $white+ { skip }
+  @number { \(_, _, _, s) len -> case Text.decimal (Text.take len s) of
+                  Left e -> Fail.fail e
+                  Right (n, txt)
+                    | Text.null txt -> pure $ TokenInt n
+                    | otherwise -> Fail.fail "got incomplete prefix " }
+  [a-z]+  { \(_, _, _, s) len -> do
+                let name = Text.take len s
+                alexSeenVar name
+                pure $ TokenVar name }
+  [\+]    { mk0ary TokenAdd }
+  [\-]    { mk0ary TokenSub }
+  [\*]    { mk0ary TokenMul }
+  [\/]    { mk0ary TokenDiv }
+  [\^]    { mk0ary TokenPow }
+  [\(]    { mk0ary TokenLPar }
+  [\)]    { mk0ary TokenRPar }
+
+{
+mk0ary :: (Read integer, Integral integer) => Token integer -> AlexInput -> Int -> Alex (Token integer)
+mk0ary tok _ _ = pure tok
+
+data AlexUserState
+  = AlexUserState {
+      ausVars :: Set Text
+  } deriving (Eq, Read, Show)
+
+alexSeenVar :: Text -> Alex ()
+alexSeenVar txt = do
+  AlexUserState { ausVars = set } <- alexGetUserState
+  alexSetUserState $ AlexUserState { ausVars = txt `Set.insert` set }
+
+alexInitUserState :: AlexUserState
+alexInitUserState = AlexUserState { ausVars = Set.empty }
+
+data Token integer
+  = TokenInt integer
+  | TokenVar Text
+  | TokenLPar
+  | TokenRPar
+  | TokenPow
+  | TokenDiv
+  | TokenMul
+  | TokenSub
+  | TokenAdd
+  | EOF
+  deriving (Eq, Read, Show)
+
+alexEOF :: (Read integer, Integral integer) => Alex (Token integer)
+alexEOF = pure EOF
+
+instance MonadFail Alex where
+  fail s = Alex . const $ Left s
+
+evalAlex :: Text -> Alex t -> Either String (AlexUserState, t)
+evalAlex txt alex = right (first getUserState) $ f state where
+  f = unAlex alex
+  getUserState AlexState { alex_ust = userState } = userState
+  state = AlexState
+    { alex_bytes = []
+    , alex_pos = alexStartPos
+    , alex_inp = txt
+    , alex_chr = '\n'
+    , alex_ust = alexInitUserState
+    , alex_scd = 0 }
+
+scanAll :: (Eq integer, Integral integer, Read integer, Show integer) => Alex [Token integer]
+scanAll = alexMonadScan >>= \result -> case result of
+  EOF -> pure []
+  tok -> (tok :) <$> scanAll
+
+tests :: [(Text, Set Text, [Token Natural])]
+tests = [ (Text.pack "x*y/(x^3+y^3)"
+          , Set.fromList [x, y]
+          , [TokenVar x, TokenMul, TokenVar y, TokenDiv, TokenLPar, TokenVar x, TokenPow, TokenInt 3, TokenAdd, TokenVar y, TokenPow, TokenInt 3, TokenRPar])] where
+  x = Text.pack "x"
+  y = Text.pack "y"
+
+main :: IO ()
+main = do
+  forM_ tests $ \(txt, vars, toks) -> do
+    case evalAlex txt scanAll of
+      Right (AlexUserState { ausVars = tokVars }, tokList)
+        | tokVars == vars && toks == tokList -> pure ()
+        | otherwise -> do
+            when (toks /= tokList) $ do
+              putStrLn $ "got " <> show tokList
+              putStrLn $ "wanted " <> show toks
+            when (tokVars /= vars) $ do
+              putStrLn $ "got " <> show tokVars
+              putStrLn $ "wanted " <> show vars
+            exitFailure
+      Left errorString -> do
+        putStrLn $ "got error " <> errorString
+        exitFailure
+  exitSuccess
+}