-- -----------------------------------------------------------------------------

-- Alex wrapper code.

--

-- 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)

import Control.Applicative as App (Applicative (..))

import qualified Control.Monad (ap)

#endif

import Data.Word (Word8)

#if defined(ALEX_BASIC_BYTESTRING) || defined(ALEX_POSN_BYTESTRING) || defined(ALEX_MONAD_BYTESTRING)

import Data.Int (Int64)

import qualified Data.Char

import qualified Data.ByteString.Lazy     as ByteString

import qualified Data.ByteString.Internal as ByteString (w2c)

#elif defined(ALEX_STRICT_BYTESTRING)

import qualified Data.Char

import qualified Data.ByteString          as ByteString

import qualified Data.ByteString.Internal as ByteString hiding (ByteString)

import qualified Data.ByteString.Unsafe   as ByteString

#else

import Data.Char (ord)

import qualified Data.Bits

-- | Encode a Haskell String to a list of Word8 values, in UTF8 format.

utf8Encode :: Char -> [Word8]

utf8Encode = map fromIntegral . go . ord

 where

  go oc

   | oc <= 0x7f       = [oc]

   | oc <= 0x7ff      = [ 0xc0 + (oc `Data.Bits.shiftR` 6)

                        , 0x80 + oc Data.Bits..&. 0x3f

                        ]

   | oc <= 0xffff     = [ 0xe0 + (oc `Data.Bits.shiftR` 12)

                        , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)

                        , 0x80 + oc Data.Bits..&. 0x3f

                        ]

   | otherwise        = [ 0xf0 + (oc `Data.Bits.shiftR` 18)

                        , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)

                        , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)

                        , 0x80 + oc Data.Bits..&. 0x3f

                        ]

#endif

type Byte = Word8

-- -----------------------------------------------------------------------------

-- The input type

#if defined(ALEX_POSN) || defined(ALEX_MONAD) || defined(ALEX_GSCAN)

type AlexInput = (AlexPosn,     -- current position,

                  Char,         -- previous char

                  [Byte],       -- pending bytes on current char

                  String)       -- current input string

ignorePendingBytes :: AlexInput -> AlexInput

ignorePendingBytes (p,c,_ps,s) = (p,c,[],s)

alexInputPrevChar :: AlexInput -> Char

alexInputPrevChar (_p,c,_bs,_s) = c

alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)

alexGetByte (p,c,(b:bs),s) = Just (b,(p,c,bs,s))

alexGetByte (_,_,[],[]) = Nothing

alexGetByte (p,_,[],(c:s))  = let p' = alexMove p c

                                  (b:bs) = utf8Encode c

                              in p' `seq`  Just (b, (p', c, bs, s))

#endif

#if defined(ALEX_POSN_BYTESTRING) || defined(ALEX_MONAD_BYTESTRING)

type AlexInput = (AlexPosn,     -- current position,

                  Char,         -- previous char

                  ByteString.ByteString,        -- current input string

                  Int64)           -- bytes consumed so far

ignorePendingBytes :: AlexInput -> AlexInput

ignorePendingBytes i = i   -- no pending bytes when lexing bytestrings

alexInputPrevChar :: AlexInput -> Char

alexInputPrevChar (_,c,_,_) = c

alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)

alexGetByte (p,_,cs,n) =

    case ByteString.uncons cs of

        Nothing -> Nothing

        Just (b, cs') ->

            let c   = ByteString.w2c b

                p'  = alexMove p c

                n'  = n+1

            in p' `seq` cs' `seq` n' `seq` Just (b, (p', c, cs',n'))

#endif

#ifdef ALEX_BASIC_BYTESTRING

data AlexInput = AlexInput { alexChar :: {-# UNPACK #-} !Char,      -- previous char

                             alexStr ::  !ByteString.ByteString,    -- current input string

                             alexBytePos :: {-# UNPACK #-} !Int64}  -- bytes consumed so far

alexInputPrevChar :: AlexInput -> Char

alexInputPrevChar = alexChar

alexGetByte (AlexInput {alexStr=cs,alexBytePos=n}) =

    case ByteString.uncons cs of

        Nothing -> Nothing

        Just (c, rest) ->

            Just (c, AlexInput {

                alexChar = ByteString.w2c c,

                alexStr =  rest,

                alexBytePos = n+1})

#endif

#ifdef ALEX_STRICT_BYTESTRING

data AlexInput = AlexInput { alexChar :: {-# UNPACK #-} !Char,

                             alexStr :: {-# UNPACK #-} !ByteString.ByteString,

                             alexBytePos :: {-# UNPACK #-} !Int}

alexInputPrevChar :: AlexInput -> Char

alexInputPrevChar = alexChar

alexGetByte (AlexInput {alexStr=cs,alexBytePos=n}) =

    case ByteString.uncons cs of

        Nothing -> Nothing

        Just (c, rest) ->

            Just (c, AlexInput {

                alexChar = ByteString.w2c c,

                alexStr =  rest,

                alexBytePos = n+1})

#endif

-- -----------------------------------------------------------------------------

-- Token positions

-- `Posn' records the location of a token in the input text.  It has three

-- fields: the address (number of chacaters preceding the token), line number

-- and column of a token within the file. `start_pos' gives the position of the

-- start of the file and `eof_pos' a standard encoding for the end of file.

-- `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)

data AlexPosn = AlexPn !Int !Int !Int

        deriving (Eq,Show)

alexStartPos :: AlexPosn

alexStartPos = AlexPn 0 1 1

alexMove :: AlexPosn -> Char -> AlexPosn

alexMove (AlexPn a l c) '\t' = AlexPn (a+1)  l     (((c+alex_tab_size-1) `div` alex_tab_size)*alex_tab_size+1)

alexMove (AlexPn a l _) '\n' = AlexPn (a+1) (l+1)   1

alexMove (AlexPn a l c) _    = AlexPn (a+1)  l     (c+1)

#endif

-- -----------------------------------------------------------------------------

-- Default monad

#ifdef ALEX_MONAD

data AlexState = AlexState {

        alex_pos :: !AlexPosn,  -- position at current input location

        alex_inp :: String,     -- the current input

        alex_chr :: !Char,      -- the character before the input

        alex_bytes :: [Byte],

        alex_scd :: !Int        -- the current startcode

#ifdef ALEX_MONAD_USER_STATE

      , alex_ust :: AlexUserState -- AlexUserState will be defined in the user program

#endif

    }

-- Compile with -funbox-strict-fields for best results!

runAlex :: String -> Alex a -> Either String a

runAlex input__ (Alex f)

   = case f (AlexState {alex_pos = alexStartPos,

                        alex_inp = input__,

                        alex_chr = '\n',

                        alex_bytes = [],

#ifdef ALEX_MONAD_USER_STATE

                        alex_ust = alexInitUserState,

#endif

                        alex_scd = 0}) of Left msg -> Left msg

                                          Right ( _, a ) -> Right a

newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) }

instance Functor Alex where

  fmap f a = Alex $ \s -> case unAlex a s of

                            Left msg -> Left msg

                            Right (s', a') -> Right (s', f a')

instance Applicative Alex where

  pure a   = Alex $ \s -> Right (s, a)

  fa <*> a = Alex $ \s -> case unAlex fa s of

                            Left msg -> Left msg

                            Right (s', f) -> case unAlex a s' of

                                               Left msg -> Left msg

                                               Right (s'', b) -> Right (s'', f b)

instance Monad Alex where

  m >>= k  = Alex $ \s -> case unAlex m s of

                                Left msg -> Left msg

                                Right (s',a) -> unAlex (k a) s'

  return = App.pure

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__))

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__, ())

alexError :: String -> Alex a

alexError message = Alex $ const $ Left message

alexGetStartCode :: Alex Int

alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc)

alexSetStartCode :: Int -> Alex ()

alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ())

#ifdef ALEX_MONAD_USER_STATE

alexGetUserState :: Alex AlexUserState

alexGetUserState = Alex $ \s@AlexState{alex_ust=ust} -> Right (s,ust)

alexSetUserState :: AlexUserState -> Alex ()

alexSetUserState ss = Alex $ \s -> Right (s{alex_ust=ss}, ())

#endif

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

-- -----------------------------------------------------------------------------

-- Useful token actions

type AlexAction result = AlexInput -> Int -> Alex result

-- just ignore this token and scan another one

-- skip :: AlexAction result

skip _input _len = alexMonadScan

-- ignore this token, but set the start code to a new value

-- begin :: Int -> AlexAction result

begin code _input _len = do alexSetStartCode code; alexMonadScan

-- perform an action for this token, and set the start code to a new value

andBegin :: AlexAction result -> Int -> AlexAction result

(action `andBegin` code) input__ len = do

  alexSetStartCode code

  action input__ len

token :: (AlexInput -> Int -> token) -> AlexAction token

token t input__ len = return (t input__ len)

#endif /* ALEX_MONAD */

-- -----------------------------------------------------------------------------

-- Monad (with ByteString input)

#ifdef ALEX_MONAD_BYTESTRING

data AlexState = AlexState {

        alex_pos :: !AlexPosn,  -- position at current input location

        alex_bpos:: !Int64,     -- bytes consumed so far

        alex_inp :: ByteString.ByteString,      -- the current input

        alex_chr :: !Char,      -- the character before the input

        alex_scd :: !Int        -- the current startcode

#ifdef ALEX_MONAD_USER_STATE

      , alex_ust :: AlexUserState -- AlexUserState will be defined in the user program

#endif

    }

-- Compile with -funbox-strict-fields for best results!

runAlex :: ByteString.ByteString -> Alex a -> Either String a

runAlex input__ (Alex f)

   = case f (AlexState {alex_pos = alexStartPos,

                        alex_bpos = 0,

                        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

newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) }

instance Functor Alex where

  fmap f m = do x <- m; return (f x)

instance Applicative Alex where

  pure a = Alex $ \s -> Right (s,a)

  (<*>) = Control.Monad.ap

instance Monad Alex where

  m >>= k  = Alex $ \s -> case unAlex m s of

                                Left msg -> Left msg

                                Right (s',a) -> unAlex (k a) s'

  return = App.pure

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))

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

                  state__@(AlexState{}) -> Right (state__, ())

alexError :: String -> Alex a

alexError message = Alex $ const $ Left message

alexGetStartCode :: Alex Int

alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc)

alexSetStartCode :: Int -> Alex ()

alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ())

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 -> do

        alexSetInput inp__'

        action (ignorePendingBytes inp__) len

      where

        len = n'-n

-- -----------------------------------------------------------------------------

-- Useful token actions

type AlexAction result = AlexInput -> Int64 -> Alex result

-- just ignore this token and scan another one

-- skip :: AlexAction result

skip _input _len = alexMonadScan

-- ignore this token, but set the start code to a new value

-- begin :: Int -> AlexAction result

begin code _input _len = do alexSetStartCode code; alexMonadScan

-- perform an action for this token, and set the start code to a new value

andBegin :: AlexAction result -> Int -> AlexAction result

(action `andBegin` code) input__ len = do

  alexSetStartCode code

  action input__ len

token :: (AlexInput -> Int64 -> token) -> AlexAction token

token t input__ len = return (t input__ len)

#endif /* ALEX_MONAD_BYTESTRING */

-- -----------------------------------------------------------------------------

-- Basic wrapper

#ifdef ALEX_BASIC

type AlexInput = (Char,[Byte],String)

alexInputPrevChar :: AlexInput -> Char

alexInputPrevChar (c,_,_) = c

-- alexScanTokens :: String -> [token]

alexScanTokens str = go ('\n',[],str)

  where go inp__@(_,_bs,s) =

          case alexScan inp__ 0 of

                AlexEOF -> []

                AlexError _ -> error "lexical error"

                AlexSkip  inp__' _ln     -> go inp__'

                AlexToken inp__' len act -> act (take len s) : go inp__'

alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)

alexGetByte (c,(b:bs),s) = Just (b,(c,bs,s))

alexGetByte (_,[],[])    = Nothing

alexGetByte (_,[],(c:s)) = case utf8Encode c of

                             (b:bs) -> Just (b, (c, bs, s))

                             [] -> Nothing

#endif

-- -----------------------------------------------------------------------------

-- Basic wrapper, ByteString version

#ifdef ALEX_BASIC_BYTESTRING

-- alexScanTokens :: ByteString.ByteString -> [token]

alexScanTokens str = go (AlexInput '\n' str 0)

  where go inp__ =

          case alexScan inp__ 0 of

                AlexEOF -> []

                AlexError _ -> error "lexical error"

                AlexSkip  inp__' _len  -> go inp__'

                AlexToken inp__' _ act ->

                  let len = alexBytePos inp__' - alexBytePos inp__ in

                  act (ByteString.take len (alexStr inp__)) : go inp__'

#endif

#ifdef ALEX_STRICT_BYTESTRING

-- alexScanTokens :: ByteString.ByteString -> [token]

alexScanTokens str = go (AlexInput '\n' str 0)

  where go inp__ =

          case alexScan inp__ 0 of

                AlexEOF -> []

                AlexError _ -> error "lexical error"

                AlexSkip  inp__' _len  -> go inp__'

                AlexToken inp__' _ act ->

                  let len = alexBytePos inp__' - alexBytePos inp__ in

                  act (ByteString.take len (alexStr inp__)) : go inp__'

#endif

-- -----------------------------------------------------------------------------

-- Posn wrapper

-- Adds text positions to the basic model.

#ifdef ALEX_POSN

--alexScanTokens :: String -> [token]

alexScanTokens str0 = go (alexStartPos,'\n',[],str0)

  where go inp__@(pos,_,_,str) =

          case alexScan inp__ 0 of

                AlexEOF -> []

                AlexError ((AlexPn _ line column),_,_,_) -> error $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column)

                AlexSkip  inp__' _ln     -> go inp__'

                AlexToken inp__' len act -> act pos (take len str) : go inp__'

#endif

-- -----------------------------------------------------------------------------

-- Posn wrapper, ByteString version

#ifdef ALEX_POSN_BYTESTRING

--alexScanTokens :: ByteString.ByteString -> [token]

alexScanTokens str0 = go (alexStartPos,'\n',str0,0)

  where go inp__@(pos,_,str,n) =

          case alexScan inp__ 0 of

                AlexEOF -> []

                AlexError ((AlexPn _ line column),_,_,_) -> error $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column)

                AlexSkip  inp__' _len       -> go inp__'

                AlexToken inp__'@(_,_,_,n') _ act ->

                  act pos (ByteString.take (n'-n) str) : go inp__'

#endif

-- -----------------------------------------------------------------------------

-- GScan wrapper

-- For compatibility with previous versions of Alex, and because we can.

#ifdef ALEX_GSCAN

alexGScan stop__ state__ inp__ =

  alex_gscan stop__ alexStartPos '\n' [] inp__ (0,state__)

alex_gscan stop__ p c bs inp__ (sc,state__) =

  case alexScan (p,c,bs,inp__) sc of

        AlexEOF     -> stop__ p c inp__ (sc,state__)

        AlexError _ -> stop__ p c inp__ (sc,state__)

        AlexSkip (p',c',bs',inp__') _len ->

          alex_gscan stop__ p' c' bs' inp__' (sc,state__)

        AlexToken (p',c',bs',inp__') len k ->

           k p c inp__ len (\scs -> alex_gscan stop__ p' c' bs' inp__' scs)                  (sc,state__)

#endif