{-# LANGUAGE BangPatterns #-}
{-# 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,
    Byte,
    LexerError (..),
    alexSetInput,
    alexGetInput,
    alexGetByte,
    alexGetStartCode,
    alexError,
    alexGetPos,
  )
where

import Control.Applicative (liftA)
import qualified Data.ByteString.Internal as BS (w2c)
import qualified Data.ByteString.Lazy as BS
import Data.Int (Int64)
import Data.Loc (Loc, Pos (..))
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
  )

{-# 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 -> Maybe (Byte, AlexInput)
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 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1
       in Pos
p' Pos -> Maybe (Byte, AlexInput) -> Maybe (Byte, AlexInput)
`seq` ByteString
cs' ByteString -> Maybe (Byte, AlexInput) -> Maybe (Byte, AlexInput)
`seq` Int64
n' Int64 -> Maybe (Byte, AlexInput) -> Maybe (Byte, AlexInput)
`seq` (Byte, AlexInput) -> Maybe (Byte, AlexInput)
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tabSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- ((Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
tabSize)) (Int
a Int -> Int -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
1 (Int
a Int -> Int -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
a Int -> Int -> Int
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 :: 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 :: Pos -> Int64 -> ByteString -> Char -> Int -> AlexState
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 -> LexerError -> Either LexerError a
forall a b. a -> Either a b
Left LexerError
msg
    Right (AlexState
_, a
a) -> a -> Either LexerError a
forall a b. b -> Either a b
Right a
a

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

data LexerError = LexerError Loc String

instance Show LexerError where
  show :: LexerError -> FilePath
show (LexerError Loc
_ FilePath
s) = FilePath
s

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

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

instance Monad Alex where
  Alex a
m >>= :: Alex a -> (a -> Alex b) -> Alex b
>>= a -> Alex b
k = (AlexState -> Either LexerError (AlexState, b)) -> Alex b
forall a. (AlexState -> Either LexerError (AlexState, a)) -> Alex a
Alex ((AlexState -> Either LexerError (AlexState, b)) -> Alex b)
-> (AlexState -> Either LexerError (AlexState, b)) -> Alex b
forall a b. (a -> b) -> a -> b
$ \AlexState
s -> case Alex a -> AlexState -> Either LexerError (AlexState, a)
forall a. Alex a -> AlexState -> Either LexerError (AlexState, a)
unAlex Alex a
m AlexState
s of
    Left LexerError
msg -> LexerError -> Either LexerError (AlexState, b)
forall a b. a -> Either a b
Left LexerError
msg
    Right (AlexState
s', a
a) -> Alex b -> AlexState -> Either LexerError (AlexState, b)
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 =
  (AlexState -> Either LexerError (AlexState, AlexInput))
-> Alex AlexInput
forall a. (AlexState -> Either LexerError (AlexState, a)) -> Alex a
Alex ((AlexState -> Either LexerError (AlexState, AlexInput))
 -> Alex AlexInput)
-> (AlexState -> Either LexerError (AlexState, AlexInput))
-> Alex AlexInput
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} ->
    (AlexState, AlexInput) -> Either LexerError (AlexState, AlexInput)
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) =
  (AlexState -> Either LexerError (AlexState, ())) -> Alex ()
forall a. (AlexState -> Either LexerError (AlexState, a)) -> Alex a
Alex ((AlexState -> Either LexerError (AlexState, ())) -> Alex ())
-> (AlexState -> Either LexerError (AlexState, ())) -> 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 {} -> (AlexState, ()) -> Either LexerError (AlexState, ())
forall a b. b -> Either a b
Right (AlexState
state, ())

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

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

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