{-# 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

