content: {-# OPTIONS_GHC -fno-warn-missing-methods #-}
  {-# LANGUAGE StrictData            #-}
  {-# LANGUAGE BangPatterns          #-}
  {-# LANGUAGE CPP                   #-}
  {-# LANGUAGE DeriveFunctor         #-}
  {-# LANGUAGE FlexibleInstances     #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE OverloadedStrings     #-}
  {-# LANGUAGE StandaloneDeriving    #-}
  {-# LANGUAGE TypeSynonymInstances  #-}
  module Skylighting.Tokenizer (
      tokenize
    , TokenizerConfig(..)
    ) where
  
  import Control.Applicative
  import Control.Monad
  import Control.Monad.Except
  import Control.Monad.Reader
  import Control.Monad.State.Strict
  import qualified Data.Attoparsec.ByteString.Char8 as A
  import Data.ByteString.Char8 (ByteString)
  import qualified Data.ByteString.Char8 as BS
  import qualified Data.ByteString.UTF8 as UTF8
  import Data.CaseInsensitive (mk)
  import Data.Char (isAlphaNum, isAscii, isDigit, isLetter, isSpace, ord)
  import qualified Data.Map as Map
  import qualified Data.IntMap as IntMap
  import Data.Maybe (catMaybes)
  import qualified Data.Set as Set
  import Data.Text (Text)
  import qualified Data.Text as Text
  import Data.Text.Encoding (decodeUtf8', encodeUtf8)
  import Debug.Trace
  import Skylighting.Regex
  import Skylighting.Types
  import Skylighting.Parser (resolveKeywords)
  import Data.List.NonEmpty (NonEmpty((:|)), (<|), toList)
  #if !MIN_VERSION_base(4,11,0)
  import Data.Semigroup
  #endif
  
  newtype Captures = Captures{ unCaptures :: IntMap.IntMap ByteString }
    deriving (Show)
  
  newtype ContextStack =
    ContextStack{ unContextStack :: NonEmpty (Context, Captures) }
    deriving (Show)
  
  data TokenizerState = TokenizerState{
      input               :: ByteString
    , endline             :: Bool
    , prevChar            :: Char
    , contextStack        :: ContextStack
    , captures            :: Captures
    , column              :: Int
    , lineContinuation    :: Bool
    , firstNonspaceColumn :: Maybe Int
  }
  
  -- | Configuration options for 'tokenize'.
  data TokenizerConfig = TokenizerConfig{
      syntaxMap   :: SyntaxMap  -- ^ Syntax map to use
    , traceOutput :: Bool       -- ^ Generate trace output for debugging
  } deriving (Show)
  
  data Result e a = Success a
                  | Failure
                  | Error e
       deriving (Functor)
  
  deriving instance (Show a, Show e) => Show (Result e a)
  
  newtype TokenizerM a = TM { runTokenizerM :: TokenizerConfig
                                            -> TokenizerState
                                            -> (TokenizerState, Result String a) }
  
  mapsnd :: (a -> b) -> (c, a) -> (c, b)
  mapsnd f (x, y) = (x, f y)
  
  instance Functor TokenizerM where
    fmap f (TM g) = TM (\c s -> mapsnd (fmap f) (g c s))
  
  instance Applicative TokenizerM where
    pure x = TM (\_ s -> (s, Success x))
    (TM f) <*> (TM y) = TM (\c s ->
                             case (f c s) of
                                (s', Failure   ) -> (s', Failure)
                                (s', Error e   ) -> (s', Error e)
                                (s', Success f') ->
                                    case (y c s') of
                                      (s'', Failure   ) -> (s'', Failure)
                                      (s'', Error e'  ) -> (s'', Error e')
                                      (s'', Success y') -> (s'', Success (f' y')))
  
  
  instance Monad TokenizerM where
    return = pure
    (TM x) >>= f = TM (\c s ->
                         case x c s of
                              (s', Failure   ) -> (s', Failure)
                              (s', Error e   ) -> (s', Error e)
                              (s', Success x') -> g c s'
                                where TM g = f x')
  
  instance Alternative TokenizerM where
    empty = TM (\_ s -> (s, Failure))
    (<|>) (TM x) (TM y) = TM (\c s ->
                             case x c s of
                                  (_, Failure   )  -> y c s
                                  (s', Error e   ) -> (s', Error e)
                                  (s', Success x') -> (s', Success x'))
    many (TM x) = TM (\c s ->
                      case x c s of
                         (_, Failure   )  -> (s, Success [])
                         (s', Error e   ) -> (s', Error e)
                         (s', Success x') -> mapsnd (fmap (x':)) (g c s')
                           where TM g = many (TM x))
    some x = (:) <$> x <*> many x
  
  instance MonadPlus TokenizerM where
    mzero = empty
    mplus = (<|>)
  
  instance MonadReader TokenizerConfig TokenizerM where
    ask = TM (\c s -> (s, Success c))
    local f (TM x) = TM (x . f)
  
  instance MonadState TokenizerState TokenizerM where
    get = TM (\_ s -> (s, Success s))
    put x = TM (\_ _ -> (x, Success ()))
  
  instance MonadError String TokenizerM where
    throwError e = TM (\_ s -> (s, Error e))
    catchError (TM x) f = TM (\c s -> case x c s of
                                        (_, Error e) -> let TM y = f e in y c s
                                        z            -> z)
  
  -- | Tokenize some text using 'Syntax'.
  tokenize :: TokenizerConfig -> Syntax -> Text -> Either String [SourceLine]
  tokenize config syntax inp =
    eitherStack >>= \(!stack) ->
      case runTokenizerM action
              config{ syntaxMap = Map.map (resolveKeywords (syntaxMap config))
                                            (syntaxMap config) }
              (startingState stack) of
         (_, Success ls) -> Right ls
         (_, Error e)    -> Left e
         (_, Failure)    -> Left "Could not tokenize code"
    where
      action = mapM tokenizeLine (zip (BS.lines (encodeUtf8 inp)) [1..])
      eitherStack = case lookupContext (sStartingContext syntax)
                           (resolveKeywords (syntaxMap config) syntax) of
                      Just c  -> Right $ ContextStack ((c, Captures mempty) :| [])
                      Nothing -> Left "No starting context specified"
      startingState stack =
        TokenizerState{ input = BS.empty
                      , endline = Text.null inp
                      , prevChar = '\n'
                      , contextStack = stack
                      , captures = Captures mempty
                      , column = 0
                      , lineContinuation = False
                      , firstNonspaceColumn = Nothing
                      }
  
  info :: String -> TokenizerM ()
  info s = do
    tr <- asks traceOutput
    when tr $ trace s (return ())
  
  infoContextStack :: TokenizerM ()
  infoContextStack = do
    tr <- asks traceOutput
    when tr $ do
      ContextStack stack <- gets contextStack
      info $ "CONTEXT STACK " ++ show (map (cName . fst) $ toList stack)
  
  popContextStack :: TokenizerM ()
  popContextStack = do
    ContextStack cs <- gets contextStack
    case cs of
         (_ :| []) -> info "WARNING: Tried to pop only element on context stack!"
         (_ :| (x:xs)) -> do
           modify (\st -> st{ contextStack = ContextStack (x :| xs) })
           infoContextStack
  
  pushContextStack :: Context -> TokenizerM ()
  pushContextStack cont = do
    modify (\st -> st{ contextStack =
                        ContextStack
                         (((cont, Captures mempty) <|) . unContextStack
                           $ contextStack st) } )
    infoContextStack
  
  currentContext :: TokenizerM Context
  currentContext = do
    ContextStack ((c,_) :| _) <- gets contextStack
    return c
  
  doContextSwitch :: ContextSwitch -> TokenizerM ()
  doContextSwitch Pop = popContextStack
  doContextSwitch (Push (!syn,!c)) = do
    syntaxes <- asks syntaxMap
    case Map.lookup syn syntaxes >>= lookupContext c of
         Just !con -> pushContextStack con
         Nothing   -> throwError $ "Unknown syntax or context: " ++ show (syn, c)
  
  doContextSwitches :: [ContextSwitch] -> TokenizerM ()
  doContextSwitches = mapM_ doContextSwitch
  
  addCaptures :: TokenizerM ()
  addCaptures = do
    capts <- gets captures
    if IntMap.null (unCaptures capts)
       then return ()
       else do
         ContextStack ((c,_) :| cs) <- gets contextStack
         info $ "Adding captures to " <> show (cName c) <> ": " <> show capts
         modify $ \st -> st{ contextStack = ContextStack ((c,capts) :| cs) }
  
  getCapture :: Int -> TokenizerM Text
  getCapture capnum = do
    ContextStack ((_,Captures capts) :| _) <- gets contextStack
    info $ "Retrieving capture " <> show capnum
    res <- case IntMap.lookup capnum capts of
            Nothing -> do
              info "Not found"
              mzero
            Just x  -> decodeBS x
    info $ "Got " <> show res
    return res
  
  lookupContext :: Text -> Syntax -> Maybe Context
  lookupContext name syntax | Text.null name =
    if Text.null (sStartingContext syntax)
       then Nothing
       else lookupContext (sStartingContext syntax) syntax
  lookupContext name syntax = Map.lookup name $ sContexts syntax
  
  tokenizeLine :: (ByteString, Int) -> TokenizerM [Token]
  tokenizeLine (!ln, !linenum) = do
    modify $ \st -> st{ input = ln, endline = BS.null ln, prevChar = '\n' }
    cur <- currentContext
    lineCont <- gets lineContinuation
    if lineCont
       then modify $ \st -> st{ lineContinuation = False }
       else do
         let !mbFirstNonspace = BS.findIndex (not . isSpace) $! ln
         modify $ \st -> st{ column = 0
                           , firstNonspaceColumn = mbFirstNonspace }
         doContextSwitches (cLineBeginContext cur)
    if BS.null ln
       then doContextSwitches (cLineEmptyContext cur)
       else doContextSwitches (cLineBeginContext cur)
    ts <- normalizeHighlighting . catMaybes <$> many getToken
    eol <- gets endline
    if eol
       then do
         currentContext >>= checkLineEnd
         return ts
       else do  -- fail if we haven't consumed whole line
         col <- gets column
         throwError $ "Could not match anything at line " ++
           show linenum ++ " column " ++ show col
  
  getToken :: TokenizerM (Maybe Token)
  getToken = do
    inp <- gets input
    gets endline >>= guard . not
    !context <- currentContext
    msum (map (\r -> tryRule r inp) (cRules context)) <|>
       case cFallthroughContext context of
             [] | cFallthrough context -> Nothing <$ doContextSwitches [Pop]
                | otherwise -> do
                    t <- normalChunk
                    let mbtok = Just (cAttribute context, t)
                    info $ "FALLTHROUGH " ++ show mbtok
                    return mbtok
             cs -> Nothing <$ doContextSwitches cs
  
  takeChars :: Int -> TokenizerM Text
  takeChars 0 = mzero
  takeChars numchars = do
    inp <- gets input
    let (bs,rest) = UTF8.splitAt numchars inp
    guard $ not (BS.null bs)
    !t <- decodeBS bs
    modify $ \st -> st{ input = rest,
                        endline = BS.null rest,
                        prevChar = Text.last t,
                        column = column st + numchars }
    return t
  
  tryRule :: Rule -> ByteString -> TokenizerM (Maybe Token)
  tryRule _    ""  = mzero
  tryRule rule inp = do
    info $ "Trying rule " ++ show rule
    case rColumn rule of
         Nothing -> return ()
         Just n  -> gets column >>= guard . (== n)
  
    when (rFirstNonspace rule) $ do
      !firstNonspace <- gets firstNonspaceColumn
      !col <- gets column
      guard (firstNonspace == Just col)
  
    oldstate <- if rLookahead rule
                   then Just <$> get -- needed for lookahead rules
                   else return Nothing
  
    -- reset regex captures
    modify $ \st -> st{ captures = Captures mempty }
  
    let attr = rAttribute rule
    mbtok <- case rMatcher rule of
                  DetectChar c -> withAttr attr $ detectChar (rDynamic rule) c inp
                  Detect2Chars c d -> withAttr attr $
                                        detect2Chars (rDynamic rule) c d inp
                  AnyChar cs -> withAttr attr $ anyChar cs inp
                  RangeDetect c d -> withAttr attr $ rangeDetect c d inp
                  RegExpr re -> withAttr attr $ regExpr (rDynamic rule) re inp
                  Int -> withAttr attr $ parseInt inp
                  HlCOct -> withAttr attr $ parseOct inp
                  HlCHex -> withAttr attr $ parseHex inp
                  HlCStringChar -> withAttr attr $ parseCStringChar inp
                  HlCChar -> withAttr attr $ parseCChar inp
                  Float -> withAttr attr $ parseFloat inp
                  Keyword _kwattr (Left listname) ->
                    throwError $ "Keyword with unresolved list " <> show listname
                  Keyword kwattr (Right kws) ->
                    withAttr attr $ keyword kwattr kws inp
                  StringDetect s -> withAttr attr $
                                      stringDetect (rDynamic rule) (rCaseSensitive rule)
                                                   s inp
                  WordDetect s -> withAttr attr $
                                      wordDetect (rCaseSensitive rule)
                                        (rWeakDeliminators rule) s inp
                  LineContinue -> withAttr attr $ lineContinue inp
                  DetectSpaces -> withAttr attr $ detectSpaces inp
                  DetectIdentifier -> withAttr attr $ detectIdentifier inp
                  IncludeRules cname -> includeRules
                     (if rIncludeAttribute rule then Just attr else Nothing)
                     cname inp
    mbchildren <- do
      inp' <- gets input
      msum (map (\r -> tryRule r inp') (rChildren rule)) <|> return Nothing
  
    mbtok' <- case mbtok of
                   Nothing -> return Nothing
                   Just (tt, s)
                     | rLookahead rule -> do
                       (oldinput, oldendline, oldprevChar, oldColumn) <-
                           case oldstate of
                                Nothing -> throwError
                                      "oldstate not saved with lookahead rule"
                                Just st -> return
                                      (input st, endline st,
                                       prevChar st, column st)
                       modify $ \st -> st{ input = oldinput
                                         , endline = oldendline
                                         , prevChar = oldprevChar
                                         , column = oldColumn }
                       return Nothing
                     | otherwise -> do
                       case mbchildren of
                            Nothing -> return $ Just (tt, s)
                            Just (_, cresult) -> return $ Just (tt, s <> cresult)
  
    info $ takeWhile (/=' ') (show (rMatcher rule)) ++ " MATCHED " ++ show mbtok'
    doContextSwitches (rContextSwitch rule)
    -- Add any captures to the context on top of the stack
    addCaptures
    return mbtok'
  
  
  withAttr :: TokenType -> TokenizerM Text -> TokenizerM (Maybe Token)
  withAttr tt p = do
    res <- p
    if Text.null res
       then return Nothing
       else return $ Just (tt, res)
  
  wordDetect :: Bool -> Set.Set Char -> Text -> ByteString -> TokenizerM Text
  wordDetect caseSensitive weakDelims s inp = do
    -- Removed the next line because KDE seems to allow
    -- \n<DOCTYPE! to match \b<DOCTYPE!/b:
    -- wordBoundary weakDelims inp
    t <- decodeBS $ UTF8.take (Text.length s) inp
    -- we assume here that the case fold will not change length,
    -- which is safe for ASCII keywords and the like...
    guard $ if caseSensitive
               then s == t
               else mk s == mk t
    guard $ not (Text.null t)
    let c = Text.last t
    let rest = UTF8.drop (Text.length s) inp
    let d = case UTF8.uncons rest of
                 Nothing    -> '\n'
                 Just (x,_) -> x
    guard $ isWordBoundary weakDelims c d
    takeChars (Text.length t)
  
  stringDetect :: Bool -> Bool -> Text -> ByteString -> TokenizerM Text
  stringDetect dynamic caseSensitive s inp = do
    s' <- if dynamic
          then do
            dynStr <- subDynamicText s
            info $ "Dynamic string: " ++ show dynStr
            return dynStr
          else return s
    t <- decodeBS $ UTF8.take (Text.length s') inp
    -- we assume here that the case fold will not change length,
    -- which is safe for ASCII keywords and the like...
    guard $ if caseSensitive
               then s' == t
               else mk s' == mk t
    takeChars (Text.length s')
  
  subDynamicText :: Text -> TokenizerM Text
  subDynamicText t = do
    let substitute x = case Text.uncons x of
          Just (c, rest) | isDigit c -> let capNum = ord c - ord '0'
                                        in (<> rest) <$> getCapture capNum
          _ -> return $ Text.cons '%' x
    case Text.split (== '%') t of
      []     -> return Text.empty
      x:rest -> (x <>) . Text.concat <$> mapM substitute rest
  
  -- This assumes that nothing significant will happen
  -- in the middle of a string of spaces or a string
  -- of alphanumerics.  This seems true  for all normal
  -- programming languages, and the optimization speeds
  -- things up a lot, relative to just parsing one char.
  normalChunk :: TokenizerM Text
  normalChunk = do
    inp <- gets input
    case UTF8.uncons inp of
      Nothing -> mzero
      Just (c, _)
        | c == ' ' ->
          let bs = BS.takeWhile (==' ') inp
          in  takeChars (BS.length bs)
        | isAscii c && isAlphaNum c ->
          let (bs, _) = UTF8.span isAlphaNum inp
          in  takeChars (UTF8.length bs)
        | otherwise -> takeChars 1
  
  includeRules :: Maybe TokenType -> ContextName -> ByteString
               -> TokenizerM (Maybe Token)
  includeRules mbattr (syn, con) inp = do
    syntaxes <- asks syntaxMap
    case Map.lookup syn syntaxes >>= lookupContext con of
         Nothing  -> do
            cur <- currentContext
            throwError $ "IncludeRules in " ++ Text.unpack (cSyntax cur) ++
             " requires undefined context " ++
             Text.unpack con ++ "##" ++ Text.unpack syn
         Just c   -> do
           mbtok <- msum (map (\r -> tryRule r inp) (cRules c))
           modify $ \st -> st{ captures = Captures mempty }
           return $ case (mbtok, mbattr) of
                      (Just (NormalTok, xs), Just attr) -> Just (attr, xs)
                      _                                 -> mbtok
  
  checkLineEnd :: Context -> TokenizerM ()
  checkLineEnd c = do
    unless (null (cLineEndContext c)) $ do
      eol <- gets endline
      info $ "checkLineEnd for " ++ show (cName c) ++ " eol = " ++ show eol ++ " cLineEndContext = " ++ show (cLineEndContext c)
      when eol $ do
        lineCont' <- gets lineContinuation
        unless lineCont' $ do
          doContextSwitches (cLineEndContext c)
          c' <- currentContext
          unless (c == c') $ checkLineEnd c'
  
  detectChar :: Bool -> Char -> ByteString -> TokenizerM Text
  detectChar dynamic c inp = do
    c' <- if dynamic && c >= '0' && c <= '9'
             then getDynamicChar c
             else return c
    case UTF8.uncons inp of
      Just (x,_) | x == c' -> takeChars 1
      _          -> mzero
  
  getDynamicChar :: Char -> TokenizerM Char
  getDynamicChar c = do
    let capNum = ord c - ord '0'
    res <- getCapture capNum
    case Text.uncons res of
         Nothing    -> mzero
         Just (d,_) -> return d
  
  detect2Chars :: Bool -> Char -> Char -> ByteString -> TokenizerM Text
  detect2Chars dynamic c d inp = do
    c' <- if dynamic && c >= '0' && c <= '9'
             then getDynamicChar c
             else return c
    d' <- if dynamic && d >= '0' && d <= '9'
             then getDynamicChar d
             else return d
    if (encodeUtf8 (Text.pack [c',d'])) `BS.isPrefixOf` inp
       then takeChars 2
       else mzero
  
  rangeDetect :: Char -> Char -> ByteString -> TokenizerM Text
  rangeDetect c d inp = do
    case UTF8.uncons inp of
      Just (x, rest)
        | x == c -> case UTF8.span (/= d) rest of
                         (in_t, out_t)
                           | BS.null out_t -> mzero
                           | otherwise -> do
                                t <- decodeBS in_t
                                takeChars (Text.length t + 2)
      _ -> mzero
  
  -- NOTE: currently limited to ASCII
  detectSpaces :: ByteString -> TokenizerM Text
  detectSpaces inp = do
    case BS.span (\c -> isSpace c) inp of
         (t, _)
           | BS.null t -> mzero
           | otherwise -> takeChars (BS.length t)
  
  -- NOTE: limited to ASCII as per kate documentation
  detectIdentifier :: ByteString -> TokenizerM Text
  detectIdentifier inp = do
    case BS.uncons inp of
      Just (c, t) | (isAscii c && isLetter c) || c == '_' ->
        takeChars $ 1 + maybe (BS.length t) id
                  (BS.findIndex (\d -> not (isAscii d) ||
                                       not (isAlphaNum d || d == '_')) t)
      _ -> mzero
  
  lineContinue :: ByteString -> TokenizerM Text
  lineContinue inp = do
    if inp == "\\"
       then do
         modify $ \st -> st{ lineContinuation = True }
         takeChars 1
       else mzero
  
  anyChar :: Set.Set Char -> ByteString -> TokenizerM Text
  anyChar cs inp = do
    case UTF8.uncons inp of
       Just (x, _) | x `Set.member` cs -> takeChars 1
       _           -> mzero
  
  regExpr :: Bool -> RE -> ByteString -> TokenizerM Text
  regExpr dynamic re inp = do
    -- return $! traceShowId $! (reStr, inp)
    let reStr = reString re
    when (BS.take 2 reStr == "\\b") $ wordBoundary mempty inp
    regex <- case compileRE re of
              Right r  -> return r
              Left e   -> throwError $
                "Error compiling regex " ++
                UTF8.toString reStr ++ ": " ++ e
    regex' <- if dynamic
                 then subDynamic regex
                 else return regex
    case matchRegex regex' inp of
          Just (matchedBytes, capts) -> do
            unless (null capts) $
              modify $ \st -> st{ captures = Captures $
                                    IntMap.map (toSlice inp) capts }
            takeChars (UTF8.length matchedBytes)
          _ -> mzero
  
  toSlice :: ByteString -> (Int, Int) -> ByteString
  toSlice bs (off, len) = BS.take len $ BS.drop off bs
  
  wordBoundary :: Set.Set Char -> ByteString -> TokenizerM ()
  wordBoundary weakDelims inp = do
    case UTF8.uncons inp of
         Nothing -> return ()
         Just (d, _) -> do
           c <- gets prevChar
           guard $ isWordBoundary weakDelims c d
  
  isWordBoundary :: Set.Set Char -> Char -> Char -> Bool
  isWordBoundary weakDelims c d =
    (isWordChar c || c `Set.member` weakDelims) /=
    (isWordChar d || d `Set.member` weakDelims)
  
  decodeBS :: ByteString -> TokenizerM Text
  decodeBS bs = case decodeUtf8' bs of
                      Left _ -> throwError ("ByteString " ++
                                  show bs ++ "is not UTF8")
                      Right t -> return t
  
  -- Substitute out %1, %2, etc. in regex string, escaping
  -- appropriately..
  subDynamic :: Regex -> TokenizerM Regex
  subDynamic (MatchDynamic capNum) = do
    replacement <- getCapture capNum
    return $ mconcat $ map (MatchChar . (==)) $ Text.unpack replacement
  subDynamic (MatchAlt r1 r2) =
    MatchAlt <$> subDynamic r1 <*> subDynamic r2
  subDynamic (MatchConcat r1 r2) =
    MatchConcat <$> subDynamic r1 <*> subDynamic r2
  subDynamic (MatchSome r) =
    MatchSome <$> subDynamic r
  subDynamic (MatchCapture i r) =
    MatchCapture i <$> subDynamic r
  subDynamic (AssertPositive dir r) =
    AssertPositive dir <$> subDynamic r
  subDynamic (AssertNegative dir r) =
    AssertNegative dir <$> subDynamic r
  subDynamic x = return x
  
  keyword :: KeywordAttr -> WordSet Text -> ByteString -> TokenizerM Text
  keyword kwattr kws inp = do
    prev <- gets prevChar
    guard $ prev `Set.member` (keywordDelims kwattr)
    let (w,_) = UTF8.break (`Set.member` (keywordDelims kwattr)) inp
    guard $ not (BS.null w)
    w' <- decodeBS w
    let numchars = Text.length w'
    if w' `inWordSet` kws
       then takeChars numchars
       else mzero
  
  normalizeHighlighting :: [Token] -> [Token]
  normalizeHighlighting [] = []
  normalizeHighlighting ((!t,!x):xs)
    | Text.null x = normalizeHighlighting xs
    | otherwise =
      (t, matchedText) : normalizeHighlighting rest
      where (matches, rest) = span (\(z,_) -> z == t) xs
            !matchedText = Text.concat (x : map snd matches)
  
  
  parseCStringChar :: ByteString -> TokenizerM Text
  parseCStringChar inp = do
    case A.parseOnly (A.match pCStringChar) inp of
         Left _      -> mzero
         Right (r,_) -> takeChars (BS.length r) -- assumes ascii
  
  pCStringChar :: A.Parser ()
  pCStringChar = do
    _ <- A.char '\\'
    next <- A.anyChar
    case next of
         c | c == 'x' || c == 'X' -> () <$ A.takeWhile1 (A.inClass "0-9a-fA-F")
           | c == '0' -> () <$ A.takeWhile (A.inClass "0-7")
           | A.inClass "abefnrtv\"'?\\" c -> return ()
           | otherwise -> mzero
  
  parseCChar :: ByteString -> TokenizerM Text
  parseCChar inp = do
    case A.parseOnly (A.match pCChar) inp of
         Left _      -> mzero
         Right (r,_) -> takeChars (BS.length r) -- assumes ascii
  
  pCChar :: A.Parser ()
  pCChar = do
    () <$ A.char '\''
    pCStringChar <|> () <$ A.satisfy (\c -> c /= '\'' && c /= '\\')
    () <$ A.char '\''
  
  parseInt :: ByteString -> TokenizerM Text
  parseInt inp = do
    wordBoundary mempty inp
    case A.parseOnly (A.match (pHex <|> pOct <|> pDec)) inp of
         Left _      -> mzero
         Right (r,_) -> takeChars (BS.length r) -- assumes ascii
  
  pDec :: A.Parser ()
  pDec = do
    mbMinus
    void $ A.takeWhile1 (A.inClass "0-9")
  
  parseOct :: ByteString -> TokenizerM Text
  parseOct inp = do
    wordBoundary mempty inp
    case A.parseOnly (A.match pHex) inp of
         Left _      -> mzero
         Right (r,_) -> takeChars (BS.length r) -- assumes ascii
  
  pOct :: A.Parser ()
  pOct = do
    mbMinus
    _ <- A.char '0'
    _ <- A.satisfy (A.inClass "Oo")
    _ <- A.takeWhile1 (A.inClass "0-7")
    return ()
  
  parseHex :: ByteString -> TokenizerM Text
  parseHex inp = do
    wordBoundary mempty inp
    case A.parseOnly (A.match pHex) inp of
         Left _      -> mzero
         Right (r,_) -> takeChars (BS.length r) -- assumes ascii
  
  pHex :: A.Parser ()
  pHex = do
    mbMinus
    _ <- A.char '0'
    _ <- A.satisfy (A.inClass "Xx")
    _ <- A.takeWhile1 (A.inClass "0-9a-fA-F")
    return ()
  
  mbMinus :: A.Parser ()
  mbMinus = (() <$ A.char '-') <|> return ()
  
  mbPlusMinus :: A.Parser ()
  mbPlusMinus = () <$ A.satisfy (A.inClass "+-") <|> return ()
  
  parseFloat :: ByteString -> TokenizerM Text
  parseFloat inp = do
    wordBoundary mempty inp
    case A.parseOnly (A.match pFloat) inp of
         Left _      -> mzero
         Right (r,_) -> takeChars (BS.length r)  -- assumes all ascii
    where pFloat :: A.Parser ()
          pFloat = do
            let digits = A.takeWhile1 (A.inClass "0-9")
            mbPlusMinus
            before <- A.option False $ True <$ digits
            dot <- A.option False $ True <$ A.satisfy (A.inClass ".")
            after <- A.option False $ True <$ digits
            e <- A.option False $ True <$ (A.satisfy (A.inClass "Ee") >>
                                           mbPlusMinus >> digits)
            mbnext <- A.peekChar
            case mbnext of
                 Nothing -> return ()
                 Just c  -> guard (not $ A.inClass "." c)
            guard $ (before && not dot && e)     -- 5e2
                 || (before && dot && (after || not e)) -- 5.2e2 or 5.2 or 5.
                 || (not before && dot && after) -- .23 or .23e2
  
  