tagToEnum# annotations in AlexWrapper C macros for -XImpredicativeTypes

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

data/AlexTemplate.hs

@@ -13,12 +13,16 @@
 #  define FAST_INT Int#
 -- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.
 #  if __GLASGOW_HASKELL__ > 706
-#    define GTE(n,m) (GHC.Exts.tagToEnum# (n >=# m))
-#    define EQ(n,m) (GHC.Exts.tagToEnum# (n ==# m))
+#    define CMP_GEQ(n,m) (((n) >=# (m)) :: Int#)
+#    define CMP_EQ(n,m) (((n) ==# (m)) :: Int#)
+#    define CMP_MKBOOL(x) ((GHC.Exts.tagToEnum# (x)) :: Bool)
 #  else
-#    define GTE(n,m) (n >=# m)
-#    define EQ(n,m) (n ==# m)
+#    define CMP_GEQ(n,m) (((n) >= (m)) :: Bool)
+#    define CMP_EQ(n,m) (((n) == (m)) :: Bool)
+#    define CMP_MKBOOL(x) ((x) :: Bool)
 #  endif
+#  define GTE(n,m) CMP_MKBOOL(CMP_GEQ(n,m))
+#  define EQ(n,m) CMP_MKBOOL(CMP_EQ(n,m))
 #  define PLUS(n,m) (n +# m)
 #  define MINUS(n,m) (n -# m)
 #  define TIMES(n,m) (n *# m)

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
+}