{-# OPTIONS_GHC -funbox-strict-fields #-}

-- | Utility definitions used by the lexer.  None of the default Alex
-- "wrappers" are precisely what we need.  The code here is based on
-- the "monad-bytestring" wrapper.  The code here is completely
-- Futhark-agnostic, and perhaps it can even serve as inspiration for
-- other Alex lexer wrappers.
module Language.Futhark.Parser.Lexer.Wrapper
  ( runAlex,
    Alex,
    AlexInput,
    alexInputPrevChar,
    Byte,
    LexerError (..),
    alexSetInput,
    alexGetInput,
    alexGetByte,
    alexGetStartCode,
    alexError,
    alexGetPos,
  )
where

import Control.Applicative (liftA)
import Data.ByteString.Internal qualified as BS (w2c)
import Data.ByteString.Lazy qualified as BS
import Data.Int (Int64)
import Data.Loc (Loc, Pos (..))
import Data.Text qualified as T
import Data.Word (Word8)

type Byte = Word8

-- | The input type.  Contains:
--
-- 1. current position
--
-- 2. previous char
--
-- 3. current input string
--
-- 4. bytes consumed so far
type AlexInput =
  ( Pos, -- current position,
    Char, -- previous char
    BS.ByteString, -- current input string
    Int64 -- bytes consumed so far
  )

alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (Pos
_, Char
prev, ByteString
_, Int64
_) = Char
prev

{-# INLINE alexGetByte #-}
alexGetByte :: AlexInput -> Maybe (Byte, AlexInput)
alexGetByte :: AlexInput -> Maybe (Byte, AlexInput)
alexGetByte (Pos
p, Char
_, ByteString
cs, Int64
n) =
  case ByteString -> Maybe (Byte, ByteString)
BS.uncons ByteString
cs of
    Maybe (Byte, ByteString)
Nothing -> forall a. Maybe a
Nothing
    Just (Byte
b, ByteString
cs') ->
      let c :: Char
c = Byte -> Char
BS.w2c Byte
b
          p' :: Pos
p' = Pos -> Char -> Pos
alexMove Pos
p Char
c
          n' :: Int64
n' = Int64
n forall a. Num a => a -> a -> a
+ Int64
1
       in Pos
p' seq :: forall a b. a -> b -> b
`seq` ByteString
cs' seq :: forall a b. a -> b -> b
`seq` Int64
n' seq :: forall a b. a -> b -> b
`seq` forall a. a -> Maybe a
Just (Byte
b, (Pos
p', Char
c, ByteString
cs', Int64
n'))

tabSize :: Int
tabSize :: Int
tabSize = Int
8

{-# INLINE alexMove #-}
alexMove :: Pos -> Char -> Pos
alexMove :: Pos -> Char -> Pos
alexMove (Pos !FilePath
f !Int
l !Int
c !Int
a) Char
'\t' = FilePath -> Int -> Int -> Int -> Pos
Pos FilePath
f Int
l (Int
c forall a. Num a => a -> a -> a
+ Int
tabSize forall a. Num a => a -> a -> a
- ((Int
c forall a. Num a => a -> a -> a
- Int
1) forall a. Integral a => a -> a -> a
`mod` Int
tabSize)) (Int
a forall a. Num a => a -> a -> a
+ Int
1)
alexMove (Pos !FilePath
f !Int
l Int
_ !Int
a) Char
'\n' = FilePath -> Int -> Int -> Int -> Pos
Pos FilePath
f (Int
l forall a. Num a => a -> a -> a
+ Int
1) Int
1 (Int
a forall a. Num a => a -> a -> a
+ Int
1)
alexMove (Pos !FilePath
f !Int
l !Int
c !Int
a) Char
_ = FilePath -> Int -> Int -> Int -> Pos
Pos FilePath
f Int
l (Int
c forall a. Num a => a -> a -> a
+ Int
1) (Int
a forall a. Num a => a -> a -> a
+ Int
1)

data AlexState = AlexState
  { AlexState -> Pos
alex_pos :: !Pos, -- position at current input location
    AlexState -> Int64
alex_bpos :: !Int64, -- bytes consumed so far
    AlexState -> ByteString
alex_inp :: BS.ByteString, -- the current input
    AlexState -> Char
alex_chr :: !Char, -- the character before the input
    AlexState -> Int
alex_scd :: !Int -- the current startcode
  }

runAlex :: Pos -> BS.ByteString -> Alex a -> Either LexerError a
runAlex :: forall a. Pos -> ByteString -> Alex a -> Either LexerError a
runAlex Pos
start_pos ByteString
input (Alex AlexState -> Either LexerError (AlexState, a)
f) =
  case AlexState -> Either LexerError (AlexState, a)
f
    ( AlexState
        { alex_pos :: Pos
alex_pos = Pos
start_pos,
          alex_bpos :: Int64
alex_bpos = Int64
0,
          alex_inp :: ByteString
alex_inp = ByteString
input,
          alex_chr :: Char
alex_chr = Char
'\n',
          alex_scd :: Int
alex_scd = Int
0
        }
    ) of
    Left LexerError
msg -> forall a b. a -> Either a b
Left LexerError
msg
    Right (AlexState
_, a
a) -> forall a b. b -> Either a b
Right a
a

newtype Alex a = Alex {forall a. Alex a -> AlexState -> Either LexerError (AlexState, a)
unAlex :: AlexState -> Either LexerError (AlexState, a)}

data LexerError = LexerError Loc T.Text

instance Show LexerError where
  show :: LexerError -> FilePath
show (LexerError Loc
_ Text
s) = Text -> FilePath
T.unpack Text
s

instance Functor Alex where
  fmap :: forall a b. (a -> b) -> Alex a -> Alex b
fmap = forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA

instance Applicative Alex where
  pure :: forall a. a -> Alex a
pure a
a = forall a. (AlexState -> Either LexerError (AlexState, a)) -> Alex a
Alex forall a b. (a -> b) -> a -> b
$ \AlexState
s -> forall a b. b -> Either a b
Right (AlexState
s, a
a)
  Alex (a -> b)
fa <*> :: forall a b. Alex (a -> b) -> Alex a -> Alex b
<*> Alex a
a = forall a. (AlexState -> Either LexerError (AlexState, a)) -> Alex a
Alex forall a b. (a -> b) -> a -> b
$ \AlexState
s -> case forall a. Alex a -> AlexState -> Either LexerError (AlexState, a)
unAlex Alex (a -> b)
fa AlexState
s of
    Left LexerError
msg -> forall a b. a -> Either a b
Left LexerError
msg
    Right (AlexState
s', a -> b
f) -> case forall a. Alex a -> AlexState -> Either LexerError (AlexState, a)
unAlex Alex a
a AlexState
s' of
      Left LexerError
msg -> forall a b. a -> Either a b
Left LexerError
msg
      Right (AlexState
s'', a
b) -> forall a b. b -> Either a b
Right (AlexState
s'', a -> b
f a
b)

instance Monad Alex where
  Alex a
m >>= :: forall a b. Alex a -> (a -> Alex b) -> Alex b
>>= a -> Alex b
k = forall a. (AlexState -> Either LexerError (AlexState, a)) -> Alex a
Alex forall a b. (a -> b) -> a -> b
$ \AlexState
s -> case forall a. Alex a -> AlexState -> Either LexerError (AlexState, a)
unAlex Alex a
m AlexState
s of
    Left LexerError
msg -> forall a b. a -> Either a b
Left LexerError
msg
    Right (AlexState
s', a
a) -> forall a. Alex a -> AlexState -> Either LexerError (AlexState, a)
unAlex (a -> Alex b
k a
a) AlexState
s'

alexGetInput :: Alex AlexInput
alexGetInput :: Alex AlexInput
alexGetInput =
  forall a. (AlexState -> Either LexerError (AlexState, a)) -> Alex a
Alex forall a b. (a -> b) -> a -> b
$ \s :: AlexState
s@AlexState {alex_pos :: AlexState -> Pos
alex_pos = Pos
pos, alex_bpos :: AlexState -> Int64
alex_bpos = Int64
bpos, alex_chr :: AlexState -> Char
alex_chr = Char
c, alex_inp :: AlexState -> ByteString
alex_inp = ByteString
inp} ->
    forall a b. b -> Either a b
Right (AlexState
s, (Pos
pos, Char
c, ByteString
inp, Int64
bpos))

alexSetInput :: AlexInput -> Alex ()
alexSetInput :: AlexInput -> Alex ()
alexSetInput (Pos
pos, Char
c, ByteString
inp, Int64
bpos) =
  forall a. (AlexState -> Either LexerError (AlexState, a)) -> Alex a
Alex forall a b. (a -> b) -> a -> b
$ \AlexState
s -> case AlexState
s
    { alex_pos :: Pos
alex_pos = Pos
pos,
      alex_bpos :: Int64
alex_bpos = Int64
bpos,
      alex_chr :: Char
alex_chr = Char
c,
      alex_inp :: ByteString
alex_inp = ByteString
inp
    } of
    state :: AlexState
state@AlexState {} -> forall a b. b -> Either a b
Right (AlexState
state, ())

alexError :: Loc -> T.Text -> Alex a
alexError :: forall a. Loc -> Text -> Alex a
alexError Loc
loc Text
message = forall a. (AlexState -> Either LexerError (AlexState, a)) -> Alex a
Alex forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Loc -> Text -> LexerError
LexerError Loc
loc Text
message

alexGetStartCode :: Alex Int
alexGetStartCode :: Alex Int
alexGetStartCode = forall a. (AlexState -> Either LexerError (AlexState, a)) -> Alex a
Alex forall a b. (a -> b) -> a -> b
$ \s :: AlexState
s@AlexState {alex_scd :: AlexState -> Int
alex_scd = Int
sc} -> forall a b. b -> Either a b
Right (AlexState
s, Int
sc)

alexGetPos :: Alex Pos
alexGetPos :: Alex Pos
alexGetPos = forall a. (AlexState -> Either LexerError (AlexState, a)) -> Alex a
Alex forall a b. (a -> b) -> a -> b
$ \AlexState
s -> forall a b. b -> Either a b
Right (AlexState
s, AlexState -> Pos
alex_pos AlexState
s)