Introduce monadUserState-strict-text wrapper

haskell · Jun 17, 2023 · 5a0a38c · 5a0a38c
1 parent b1d0de4
commit 5a0a38c
Show file tree

Hide file tree

Showing 7 changed files with 226 additions and 55 deletions.
diff --git a/alex.cabal b/alex.cabal
@@ -94,6 +94,7 @@ extra-source-files:
         tests/issue_197.x
         tests/strict_text_typeclass.x
         tests/posn_typeclass_strict_text.x
+        tests/tokens_monadUserState_strict_text.x
 
 source-repository head
     type:     git

diff --git a/data/AlexWrappers.hs b/data/AlexWrappers.hs
@@ -4,11 +4,11 @@
 -- This code is in the PUBLIC DOMAIN; you may copy it freely and use
 -- it for any purpose whatsoever.
 
-#if defined(ALEX_MONAD) || defined(ALEX_MONAD_BYTESTRING)
+#if defined(ALEX_MONAD) || defined(ALEX_MONAD_BYTESTRING) || defined(ALEX_MONAD_STRICT_TEXT)
 import Control.Applicative as App (Applicative (..))
 #endif
 
-#if defined(ALEX_STRICT_TEXT) || defined (ALEX_POSN_STRICT_TEXT)
+#if defined(ALEX_STRICT_TEXT) || defined (ALEX_POSN_STRICT_TEXT) || defined(ALEX_MONAD_STRICT_TEXT)
 import qualified Data.Text
 #endif
 
@@ -108,7 +108,7 @@ alexGetByte (_,[],s) = case Data.Text.uncons s of
                               Nothing
 #endif
 
-#if defined (ALEX_POSN_STRICT_TEXT)
+#if defined (ALEX_POSN_STRICT_TEXT) || defined(ALEX_MONAD_STRICT_TEXT)
 type AlexInput = (AlexPosn,       -- current position,
                   Char,           -- previous char
                   [Byte],         -- pending bytes on current char
@@ -200,7 +200,7 @@ alexGetByte (AlexInput {alexStr=cs,alexBytePos=n}) =
 -- `move_pos' calculates the new position after traversing a given character,
 -- assuming the usual eight character tab stops.
 
-#if defined(ALEX_POSN) || defined(ALEX_MONAD) || defined(ALEX_POSN_BYTESTRING) || defined(ALEX_MONAD_BYTESTRING) || defined(ALEX_GSCAN) || defined (ALEX_POSN_STRICT_TEXT)
+#if defined(ALEX_POSN) || defined(ALEX_MONAD) || defined(ALEX_POSN_BYTESTRING) || defined(ALEX_MONAD_BYTESTRING) || defined(ALEX_GSCAN) || defined (ALEX_POSN_STRICT_TEXT) || defined(ALEX_MONAD_STRICT_TEXT)
 data AlexPosn = AlexPn !Int !Int !Int
         deriving (Eq, Show, Ord)
 
@@ -216,14 +216,20 @@ alexMove (AlexPn a l c) _    = AlexPn (a+1)  l     (c+1)
 -- -----------------------------------------------------------------------------
 -- Monad (default and with ByteString input)
 
-#if defined(ALEX_MONAD) || defined(ALEX_MONAD_BYTESTRING)
+#if defined(ALEX_MONAD) || defined(ALEX_MONAD_BYTESTRING) || defined(ALEX_MONAD_STRICT_TEXT)
 data AlexState = AlexState {
         alex_pos :: !AlexPosn,  -- position at current input location
-#ifndef ALEX_MONAD_BYTESTRING
+#ifdef ALEX_MONAD_STRICT_TEXT
+        alex_inp :: Data.Text.Text,
+        alex_chr :: !Char,
+        alex_bytes :: [Byte],
+#endif /* ALEX_MONAD_STRICT_TEXT */
+#ifdef ALEX_MONAD
         alex_inp :: String,     -- the current input
         alex_chr :: !Char,      -- the character before the input
         alex_bytes :: [Byte],
-#else /* ALEX_MONAD_BYTESTRING */
+#endif /* ALEX_MONAD */
+#ifdef ALEX_MONAD_BYTESTRING
         alex_bpos:: !Int64,     -- bytes consumed so far
         alex_inp :: ByteString.ByteString,      -- the current input
         alex_chr :: !Char,      -- the character before the input
@@ -236,15 +242,24 @@ data AlexState = AlexState {
 
 -- Compile with -funbox-strict-fields for best results!
 
-#ifndef ALEX_MONAD_BYTESTRING
+#ifdef ALEX_MONAD 
 runAlex :: String -> Alex a -> Either String a
 runAlex input__ (Alex f)
    = case f (AlexState {alex_bytes = [],
-#else /* ALEX_MONAD_BYTESTRING */
+                        alex_pos = alexStartPos,
+                        alex_inp = input__,
+                        alex_chr = '\n',
+#ifdef ALEX_MONAD_USER_STATE
+                        alex_ust = alexInitUserState,
+#endif
+                        alex_scd = 0}) of Left msg -> Left msg
+                                          Right ( _, a ) -> Right a
+#endif
+
+#ifdef ALEX_MONAD_BYTESTRING
 runAlex :: ByteString.ByteString -> Alex a -> Either String a
 runAlex input__ (Alex f)
    = case f (AlexState {alex_bpos = 0,
-#endif /* ALEX_MONAD_BYTESTRING */
                         alex_pos = alexStartPos,
                         alex_inp = input__,
                         alex_chr = '\n',
@@ -253,6 +268,21 @@ runAlex input__ (Alex f)
 #endif
                         alex_scd = 0}) of Left msg -> Left msg
                                           Right ( _, a ) -> Right a
+#endif
+
+#ifdef ALEX_MONAD_STRICT_TEXT
+runAlex :: Data.Text.Text -> Alex a -> Either String a
+runAlex input__ (Alex f)
+   = case f (AlexState {alex_bytes = [],
+                        alex_pos = alexStartPos,
+                        alex_inp = input__,
+                        alex_chr = '\n',
+#ifdef ALEX_MONAD_USER_STATE
+                        alex_ust = alexInitUserState,
+#endif
+                        alex_scd = 0}) of Left msg -> Left msg
+                                          Right ( _, a ) -> Right a
+#endif
 
 newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) }
 
@@ -275,28 +305,51 @@ instance Monad Alex where
                                 Right (s',a) -> unAlex (k a) s'
   return = App.pure
 
+
+#ifdef ALEX_MONAD 
 alexGetInput :: Alex AlexInput
 alexGetInput
-#ifndef ALEX_MONAD_BYTESTRING
  = Alex $ \s@AlexState{alex_pos=pos,alex_chr=c,alex_bytes=bs,alex_inp=inp__} ->
         Right (s, (pos,c,bs,inp__))
-#else /* ALEX_MONAD_BYTESTRING */
+#endif
+
+#ifdef ALEX_MONAD_BYTESTRING
+alexGetInput :: Alex AlexInput
+alexGetInput
  = Alex $ \s@AlexState{alex_pos=pos,alex_bpos=bpos,alex_chr=c,alex_inp=inp__} ->
         Right (s, (pos,c,inp__,bpos))
-#endif /* ALEX_MONAD_BYTESTRING */
+#endif
+
+#ifdef ALEX_MONAD_STRICT_TEXT
+alexGetInput :: Alex AlexInput
+alexGetInput
+ = Alex $ \s@AlexState{alex_pos=pos,alex_chr=c,alex_bytes=bs,alex_inp=inp__} ->
+        Right (s, (pos,c,bs,inp__))
+#endif
 
+#ifdef ALEX_MONAD 
 alexSetInput :: AlexInput -> Alex ()
-#ifndef ALEX_MONAD_BYTESTRING
 alexSetInput (pos,c,bs,inp__)
  = Alex $ \s -> case s{alex_pos=pos,alex_chr=c,alex_bytes=bs,alex_inp=inp__} of
-#else /* ALEX_MONAD_BYTESTRING */
+                    state__@(AlexState{}) -> Right (state__, ())
+#endif
+
+#ifdef ALEX_MONAD_BYTESTRING
+alexSetInput :: AlexInput -> Alex ()
 alexSetInput (pos,c,inp__,bpos)
  = Alex $ \s -> case s{alex_pos=pos,
                        alex_bpos=bpos,
                        alex_chr=c,
                        alex_inp=inp__} of
-#endif /* ALEX_MONAD_BYTESTRING */
-                  state__@(AlexState{}) -> Right (state__, ())
+                    state__@(AlexState{}) -> Right (state__, ())
+#endif
+
+#ifdef ALEX_MONAD_STRICT_TEXT
+alexSetInput :: AlexInput -> Alex ()
+alexSetInput (pos,c,bs,inp__)
+ = Alex $ \s -> case s{alex_pos=pos,alex_chr=c,alex_bytes=bs,alex_inp=inp__} of
+                    state__@(AlexState{}) -> Right (state__, ())
+#endif
 
 alexError :: String -> Alex a
 alexError message = Alex $ const $ Left message
@@ -315,35 +368,65 @@ alexSetUserState :: AlexUserState -> Alex ()
 alexSetUserState ss = Alex $ \s -> Right (s{alex_ust=ss}, ())
 #endif /* !defined(ALEX_MONAD_BYTESTRING) && defined(ALEX_MONAD_USER_STATE) */
 
+#ifdef ALEX_MONAD
 alexMonadScan = do
-#ifndef ALEX_MONAD_BYTESTRING
   inp__ <- alexGetInput
-#else /* ALEX_MONAD_BYTESTRING */
-  inp__@(_,_,_,n) <- alexGetInput
-#endif /* ALEX_MONAD_BYTESTRING */
   sc <- alexGetStartCode
   case alexScan inp__ sc of
     AlexEOF -> alexEOF
     AlexError ((AlexPn _ line column),_,_,_) -> alexError $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column)
     AlexSkip  inp__' _len -> do
         alexSetInput inp__'
         alexMonadScan
-#ifndef ALEX_MONAD_BYTESTRING
     AlexToken inp__' len action -> do
-#else /* ALEX_MONAD_BYTESTRING */
+        alexSetInput inp__'
+        action (ignorePendingBytes inp__) len
+#endif
+
+#ifdef ALEX_MONAD_BYTESTRING
+alexMonadScan = do
+  inp__@(_,_,_,n) <- alexGetInput
+  sc <- alexGetStartCode
+  case alexScan inp__ sc of
+    AlexEOF -> alexEOF
+    AlexError ((AlexPn _ line column),_,_,_) -> alexError $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column)
+    AlexSkip  inp__' _len -> do
+        alexSetInput inp__'
+        alexMonadScan
     AlexToken inp__'@(_,_,_,n') _ action -> let len = n'-n in do
-#endif /* ALEX_MONAD_BYTESTRING */
         alexSetInput inp__'
         action (ignorePendingBytes inp__) len
+#endif
+
+#ifdef ALEX_MONAD_STRICT_TEXT
+alexMonadScan = do
+  inp__ <- alexGetInput
+  sc <- alexGetStartCode
+  case alexScan inp__ sc of
+    AlexEOF -> alexEOF
+    AlexError ((AlexPn _ line column),_,_,_) -> alexError $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column)
+    AlexSkip  inp__' _len -> do
+        alexSetInput inp__'
+        alexMonadScan
+    AlexToken inp__' len action -> do
+        alexSetInput inp__'
+        action (ignorePendingBytes inp__) len
+#endif
 
 -- -----------------------------------------------------------------------------
 -- Useful token actions
 
-#ifndef ALEX_MONAD_BYTESTRING
+#ifdef ALEX_MONAD
 type AlexAction result = AlexInput -> Int -> Alex result
-#else /* ALEX_MONAD_BYTESTRING */
+#endif
+
+#ifdef ALEX_MONAD_BYTESTRING
 type AlexAction result = AlexInput -> Int64 -> Alex result
-#endif /* ALEX_MONAD_BYTESTRING */
+#endif
+
+#ifdef ALEX_MONAD_STRICT_TEXT
+type AlexAction result = AlexInput -> Int -> Alex result
+#endif
 
 -- just ignore this token and scan another one
 -- skip :: AlexAction result
@@ -359,14 +442,22 @@ andBegin :: AlexAction result -> Int -> AlexAction result
   alexSetStartCode code
   action input__ len
 
-#ifndef ALEX_MONAD_BYTESTRING
+#ifdef ALEX_MONAD
 token :: (AlexInput -> Int -> token) -> AlexAction token
-#else /* ALEX_MONAD_BYTESTRING */
+token t input__ len = return (t input__ len)
+#endif
+
+#ifdef ALEX_MONAD_BYTESTRING
 token :: (AlexInput -> Int64 -> token) -> AlexAction token
-#endif /* ALEX_MONAD_BYTESTRING */
 token t input__ len = return (t input__ len)
-#endif /* defined(ALEX_MONAD) || defined(ALEX_MONAD_BYTESTRING) */
+#endif
+
+#ifdef ALEX_MONAD_STRICT_TEXT
+token :: (AlexInput -> Int -> token) -> AlexAction token
+token t input__ len = return (t input__ len)
+#endif
 
+#endif /* defined(ALEX_MONAD) || defined(ALEX_MONAD_BYTESTRING) || defined(ALEX_MONAD_STRICT_TEXT) */
 
 -- -----------------------------------------------------------------------------
 -- Basic wrapper

diff --git a/src/AbsSyn.hs b/src/AbsSyn.hs
@@ -50,6 +50,7 @@ data Directive
    deriving Show
 
 data StrType = Str | Lazy | Strict | StrictText
+  deriving Eq
 
 instance Show StrType where
   show Str = "String"
@@ -64,7 +65,8 @@ data Scheme
             basicTypeInfo :: Maybe (Maybe String, String) }
   | Posn { posnStrType :: StrType,
            posnTypeInfo :: Maybe (Maybe String, String) }
-  | Monad { monadByteString :: Bool, monadUserState :: Bool,
+  | Monad { monadStrType :: StrType,
+            monadUserState :: Bool,
             monadTypeInfo :: Maybe (Maybe String, String) }
 
 wrapperCppDefs :: Scheme -> Maybe [String]
@@ -78,14 +80,22 @@ wrapperCppDefs Posn { posnStrType = Str } = Just ["ALEX_POSN"]
 wrapperCppDefs Posn { posnStrType = Lazy } = Just ["ALEX_POSN_BYTESTRING"]
 wrapperCppDefs Posn { posnStrType = Strict } = Just ["ALEX_POSN_BYTESTRING"]
 wrapperCppDefs Posn { posnStrType = StrictText } = Just ["ALEX_POSN_STRICT_TEXT"]
-wrapperCppDefs Monad { monadByteString = False,
+wrapperCppDefs Monad { monadStrType = Str,
                        monadUserState = False } = Just ["ALEX_MONAD"]
-wrapperCppDefs Monad { monadByteString = True,
+wrapperCppDefs Monad { monadStrType = Strict,
+                       monadUserState = False } = Just ["ALEX_MONAD_BYTESTRING"]
+wrapperCppDefs Monad { monadStrType = Lazy,
                        monadUserState = False } = Just ["ALEX_MONAD_BYTESTRING"]
-wrapperCppDefs Monad { monadByteString = False,
+wrapperCppDefs Monad { monadStrType = StrictText,
+                       monadUserState = False } = Just ["ALEX_MONAD_STRICT_TEXT"]
+wrapperCppDefs Monad { monadStrType = Str,
                        monadUserState = True } = Just ["ALEX_MONAD", "ALEX_MONAD_USER_STATE"]
-wrapperCppDefs Monad { monadByteString = True,
+wrapperCppDefs Monad { monadStrType = Strict,
+                       monadUserState = True } = Just ["ALEX_MONAD_BYTESTRING", "ALEX_MONAD_USER_STATE"]
+wrapperCppDefs Monad { monadStrType = Lazy,
                        monadUserState = True } = Just ["ALEX_MONAD_BYTESTRING", "ALEX_MONAD_USER_STATE"]
+wrapperCppDefs Monad { monadStrType = StrictText,
+                       monadUserState = True } = Just ["ALEX_MONAD_STRICT_TEXT", "ALEX_MONAD_USER_STATE"]
 
 -- TODO: update this comment
 --
@@ -376,17 +386,17 @@ extractActions scheme scanner = (scanner{scannerTokens = new_tokens}, decl_str .
            posnTypeInfo = Just (Just tyclasses, tokenty) } -> nl .
       str fun . str " :: (" . str tyclasses . str ") => AlexPosn -> " .
       str (show strty) . str " -> " . str tokenty . nl
-    Monad { monadByteString = isByteString,
+    Monad { monadStrType = strty,
             monadTypeInfo = Just (Nothing, tokenty) } -> nl .
       let
-        actintty = if isByteString then "Int64" else "Int"
+        actintty = if strty == Lazy then "Int64" else "Int"
       in
         str fun . str " :: AlexInput -> " . str actintty . str " -> Alex ("
       . str tokenty . str ")" . nl
-    Monad { monadByteString = isByteString,
+    Monad { monadStrType = strty,
             monadTypeInfo = Just (Just tyclasses, tokenty) } -> nl .
       let
-        actintty = if isByteString then "Int64" else "Int"
+        actintty = if strty == Lazy then "Int64" else "Int"
       in
         str fun . str " :: (" . str tyclasses . str ") =>"
       . str " AlexInput -> " . str actintty

diff --git a/src/Main.hs b/src/Main.hs
@@ -333,25 +333,29 @@ getScheme directives =
                   dieAlex "%action directive not allowed with a wrapper"
               (Just _, Nothing, Nothing) ->
                 dieAlex "%typeclass directive without %token directive"
-          | single == "monad" || single == "monad-bytestring" ||
+          | single == "monad" || single == "monad-bytestring" || single == "monad-strict-text" ||
             single == "monadUserState" ||
-            single == "monadUserState-bytestring" ->
+            single == "monadUserState-bytestring" ||
+            single == "monadUserState-strict-text" ->
             let
+              isText = single == "monad-strict-text" || 
+                       single == "monadUserState-strict-text"
               isByteString = single == "monad-bytestring" ||
                              single == "monadUserState-bytestring"
               userState = single == "monadUserState" ||
-                          single == "monadUserState-bytestring"
+                          single == "monadUserState-bytestring" ||
+                          single == "monadUserState-strict-text"
             in case (typeclass, token, action) of
               (Nothing, Nothing, Nothing) ->
-                return Monad { monadByteString = isByteString,
+                return Monad { monadStrType = if isByteString then Lazy else if isText then StrictText else Str,
                                monadUserState = userState,
                                monadTypeInfo = Nothing }
               (Nothing, Just tokenty, Nothing) ->
-                return Monad { monadByteString = isByteString,
+                return Monad { monadStrType = if isByteString then Lazy else if isText then StrictText else Str,
                                monadUserState = userState,
                                monadTypeInfo = Just (Nothing, tokenty) }
               (Just _, Just tokenty, Nothing) ->
-                return Monad { monadByteString = isByteString,
+                return Monad { monadStrType = if isByteString then Lazy else if isText then StrictText else Str,
                                monadUserState = userState,
                                monadTypeInfo = Just (typeclass, tokenty) }
               (_, _, Just _) ->