{-# LANGUAGE TemplateHaskell, CPP #-}
module AlexToolsBin
  ( -- * Lexer Basics
    initialInput, Input(..), inputFile
  , Lexeme(..)
  , SourcePos(..), startPos, beforeStartPos, prevPos
  , SourceRange(..)
  , prettySourcePos, prettySourceRange
  , prettySourcePosLong, prettySourceRangeLong
  , HasRange(..)
  , (<->)
  , moveSourcePos

    -- * Writing Lexer Actions
  , Action(..)

    -- ** Lexemes
  , lexeme
  , matchLength
  , matchRange
  , matchBytes

    -- ** Manipulating the lexer's state
  , getLexerState
  , setLexerState

    -- ** Access to the lexer's input
  , startInput
  , endInput

    -- * Interface with Alex
  , AlexInput
  , alexInputPrevChar
  , alexGetByte
  , makeLexer
  , LexerConfig(..)
  , simpleLexer
  , Word8

  ) where

import           Control.DeepSeq
import           Data.Word(Word8)
import           Data.ByteString(ByteString)
import qualified Data.ByteString as BS
import           Data.Text(Text)
import qualified Data.Text as Text
import           Control.Monad(liftM,ap,replicateM)
import           Language.Haskell.TH
#if !MIN_VERSION_base(4,8,0)
import           Control.Applicative
#endif

data Lexeme t = Lexeme
  { forall t. Lexeme t -> ByteString
lexemeBytes :: !ByteString
  , forall t. Lexeme t -> t
lexemeToken :: !t
  , forall t. Lexeme t -> SourceRange
lexemeRange :: !SourceRange
  } deriving (Int -> Lexeme t -> ShowS
forall t. Show t => Int -> Lexeme t -> ShowS
forall t. Show t => [Lexeme t] -> ShowS
forall t. Show t => Lexeme t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Lexeme t] -> ShowS
$cshowList :: forall t. Show t => [Lexeme t] -> ShowS
show :: Lexeme t -> String
$cshow :: forall t. Show t => Lexeme t -> String
showsPrec :: Int -> Lexeme t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> Lexeme t -> ShowS
Show, Lexeme t -> Lexeme t -> Bool
forall t. Eq t => Lexeme t -> Lexeme t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Lexeme t -> Lexeme t -> Bool
$c/= :: forall t. Eq t => Lexeme t -> Lexeme t -> Bool
== :: Lexeme t -> Lexeme t -> Bool
$c== :: forall t. Eq t => Lexeme t -> Lexeme t -> Bool
Eq)

instance NFData t => NFData (Lexeme t) where
  rnf :: Lexeme t -> ()
rnf (Lexeme ByteString
x t
y SourceRange
z) = forall a. NFData a => a -> ()
rnf (ByteString
x,t
y,SourceRange
z)

data SourcePos = SourcePos
  { SourcePos -> Int
sourceIndex :: !Int
  , SourcePos -> Text
sourceFile  :: !Text
  } deriving (Int -> SourcePos -> ShowS
[SourcePos] -> ShowS
SourcePos -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SourcePos] -> ShowS
$cshowList :: [SourcePos] -> ShowS
show :: SourcePos -> String
$cshow :: SourcePos -> String
showsPrec :: Int -> SourcePos -> ShowS
$cshowsPrec :: Int -> SourcePos -> ShowS
Show, SourcePos -> SourcePos -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SourcePos -> SourcePos -> Bool
$c/= :: SourcePos -> SourcePos -> Bool
== :: SourcePos -> SourcePos -> Bool
$c== :: SourcePos -> SourcePos -> Bool
Eq)

-- | Pretty print the source position without the file name.
prettySourcePos :: SourcePos -> String
prettySourcePos :: SourcePos -> String
prettySourcePos SourcePos
x = forall a. Show a => a -> String
show (SourcePos -> Int
sourceIndex SourcePos
x)

-- | Pretty print the source position, including the file name.
prettySourcePosLong :: SourcePos -> String
prettySourcePosLong :: SourcePos -> String
prettySourcePosLong SourcePos
x = Text -> String
Text.unpack (SourcePos -> Text
sourceFile SourcePos
x) forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (SourcePos -> Int
sourceIndex SourcePos
x)

instance NFData SourcePos where
  rnf :: SourcePos -> ()
rnf (SourcePos {}) = ()

-- | Update a 'SourcePos' for a particular matched character
moveSourcePos :: SourcePos -> SourcePos
moveSourcePos :: SourcePos -> SourcePos
moveSourcePos SourcePos
p = SourcePos
p { sourceIndex :: Int
sourceIndex = SourcePos -> Int
sourceIndex SourcePos
p forall a. Num a => a -> a -> a
+ Int
1 }

-- | A range in the source code.
data SourceRange = SourceRange
  { SourceRange -> SourcePos
sourceFrom :: !SourcePos
  , SourceRange -> SourcePos
sourceTo   :: !SourcePos
  } deriving (Int -> SourceRange -> ShowS
[SourceRange] -> ShowS
SourceRange -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SourceRange] -> ShowS
$cshowList :: [SourceRange] -> ShowS
show :: SourceRange -> String
$cshow :: SourceRange -> String
showsPrec :: Int -> SourceRange -> ShowS
$cshowsPrec :: Int -> SourceRange -> ShowS
Show, SourceRange -> SourceRange -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SourceRange -> SourceRange -> Bool
$c/= :: SourceRange -> SourceRange -> Bool
== :: SourceRange -> SourceRange -> Bool
$c== :: SourceRange -> SourceRange -> Bool
Eq)

-- | Pretty print the range, without the file name
prettySourceRange :: SourceRange -> String
prettySourceRange :: SourceRange -> String
prettySourceRange SourceRange
x = SourcePos -> String
prettySourcePos (SourceRange -> SourcePos
sourceFrom SourceRange
x) forall a. [a] -> [a] -> [a]
++ String
"--" forall a. [a] -> [a] -> [a]
++
                      SourcePos -> String
prettySourcePos (SourceRange -> SourcePos
sourceTo SourceRange
x)

-- | Pretty print the range, including the file name.
prettySourceRangeLong :: SourceRange -> String
prettySourceRangeLong :: SourceRange -> String
prettySourceRangeLong SourceRange
x
  | SourcePos -> Text
sourceFile SourcePos
pfrom forall a. Eq a => a -> a -> Bool
== SourcePos -> Text
sourceFile SourcePos
pto =
    Text -> String
Text.unpack (SourcePos -> Text
sourceFile SourcePos
pfrom) forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++
    SourcePos -> String
prettySourcePos SourcePos
pfrom forall a. [a] -> [a] -> [a]
++ String
"--" forall a. [a] -> [a] -> [a]
++ SourcePos -> String
prettySourcePos SourcePos
pto
  | Bool
otherwise = SourcePos -> String
prettySourcePosLong SourcePos
pfrom forall a. [a] -> [a] -> [a]
++ String
"--" forall a. [a] -> [a] -> [a]
++
                SourcePos -> String
prettySourcePosLong SourcePos
pto
  where
  pfrom :: SourcePos
pfrom = SourceRange -> SourcePos
sourceFrom SourceRange
x
  pto :: SourcePos
pto   = SourceRange -> SourcePos
sourceTo SourceRange
x



instance NFData SourceRange where
  rnf :: SourceRange -> ()
rnf (SourceRange {}) = ()

class HasRange t where
  range :: t -> SourceRange

instance HasRange SourcePos where
  range :: SourcePos -> SourceRange
range SourcePos
p = SourceRange { sourceFrom :: SourcePos
sourceFrom = SourcePos
p, sourceTo :: SourcePos
sourceTo = SourcePos
p }

instance HasRange SourceRange where
  range :: SourceRange -> SourceRange
range = forall a. a -> a
id

instance HasRange (Lexeme t) where
  range :: Lexeme t -> SourceRange
range = forall t. Lexeme t -> SourceRange
lexemeRange

instance (HasRange a, HasRange b) => HasRange (Either a b) where
  range :: Either a b -> SourceRange
range (Left a
x)  = forall t. HasRange t => t -> SourceRange
range a
x
  range (Right b
x) = forall t. HasRange t => t -> SourceRange
range b
x

(<->) :: (HasRange a, HasRange b) => a -> b -> SourceRange
a
x <-> :: forall a b. (HasRange a, HasRange b) => a -> b -> SourceRange
<-> b
y = SourceRange { sourceFrom :: SourcePos
sourceFrom = SourceRange -> SourcePos
sourceFrom (forall t. HasRange t => t -> SourceRange
range a
x)
                      , sourceTo :: SourcePos
sourceTo   = SourceRange -> SourcePos
sourceTo   (forall t. HasRange t => t -> SourceRange
range b
y)
                      }

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

-- | An action to be taken when a regular expression matchers.
newtype Action s a = A { forall s a. Action s a -> Input -> Input -> Int -> s -> (s, a)
runA :: Input -> Input -> Int -> s -> (s, a) }

instance Functor (Action s) where
  fmap :: forall a b. (a -> b) -> Action s a -> Action s b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative (Action s) where
  pure :: forall a. a -> Action s a
pure a
a = forall s a. (Input -> Input -> Int -> s -> (s, a)) -> Action s a
A (\Input
_ Input
_ Int
_ s
s -> (s
s,a
a))
  <*> :: forall a b. Action s (a -> b) -> Action s a -> Action s b
(<*>)  = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (Action s) where
  return :: forall a. a -> Action s a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  A Input -> Input -> Int -> s -> (s, a)
m >>= :: forall a b. Action s a -> (a -> Action s b) -> Action s b
>>= a -> Action s b
f = forall s a. (Input -> Input -> Int -> s -> (s, a)) -> Action s a
A (\Input
i1 Input
i2 Int
l s
s -> let (s
s1,a
a)    = Input -> Input -> Int -> s -> (s, a)
m Input
i1 Input
i2 Int
l s
s
                                   A Input -> Input -> Int -> s -> (s, b)
m1 =  a -> Action s b
f a
a
                               in Input -> Input -> Int -> s -> (s, b)
m1 Input
i1 Input
i2 Int
l s
s1)

-- | Acces the input just before the regular expression started matching.
startInput :: Action s Input
startInput :: forall s. Action s Input
startInput = forall s a. (Input -> Input -> Int -> s -> (s, a)) -> Action s a
A (\Input
i1 Input
_ Int
_ s
s -> (s
s,Input
i1))

-- | Acces the input just after the regular expression that matched.
endInput :: Action s Input
endInput :: forall s. Action s Input
endInput = forall s a. (Input -> Input -> Int -> s -> (s, a)) -> Action s a
A (\Input
_ Input
i2 Int
_ s
s -> (s
s,Input
i2))

-- | The number of characters in the matching input.
matchLength :: Action s Int
matchLength :: forall s. Action s Int
matchLength = forall s a. (Input -> Input -> Int -> s -> (s, a)) -> Action s a
A (\Input
_ Input
_ Int
l s
s -> (s
s,Int
l))

-- | Acces the curent state of the lexer.
getLexerState :: Action s s
getLexerState :: forall s. Action s s
getLexerState = forall s a. (Input -> Input -> Int -> s -> (s, a)) -> Action s a
A (\Input
_ Input
_ Int
_ s
s -> (s
s,s
s))

-- | Change the state of the lexer.
setLexerState :: s -> Action s ()
setLexerState :: forall s. s -> Action s ()
setLexerState s
s = forall s a. (Input -> Input -> Int -> s -> (s, a)) -> Action s a
A (\Input
_ Input
_ Int
_ s
_ -> (s
s,()))

-- | Get the range for the matching input.
matchRange :: Action s SourceRange
matchRange :: forall s. Action s SourceRange
matchRange =
  do Input
i1 <- forall s. Action s Input
startInput
     Input
i2 <- forall s. Action s Input
endInput
     forall (m :: * -> *) a. Monad m => a -> m a
return (Input -> SourcePos
inputPos Input
i1 forall a b. (HasRange a, HasRange b) => a -> b -> SourceRange
<-> Input -> SourcePos
inputPrev Input
i2)

-- | Get the text associated with the matched input.
matchBytes :: Action s ByteString
matchBytes :: forall s. Action s ByteString
matchBytes =
  do Input
i1 <- forall s. Action s Input
startInput
     Int
n  <- forall s. Action s Int
matchLength
     forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ByteString -> ByteString
BS.take Int
n (Input -> ByteString
inputBytes Input
i1))

-- | Use the token and the current match to construct a lexeme.
lexeme :: t -> Action s [Lexeme t]
lexeme :: forall t s. t -> Action s [Lexeme t]
lexeme t
tok =
  do SourceRange
r   <- forall s. Action s SourceRange
matchRange
     ByteString
txt <- forall s. Action s ByteString
matchBytes
     let l :: Lexeme t
l = Lexeme { lexemeRange :: SourceRange
lexemeRange = SourceRange
r
                    , lexemeToken :: t
lexemeToken = t
tok
                    , lexemeBytes :: ByteString
lexemeBytes = ByteString
txt
                    }
     Lexeme t
l seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return [ Lexeme t
l ]

-- | Information about the lexer's input.
data Input = Input
  { Input -> SourcePos
inputPos      :: {-# UNPACK #-} !SourcePos
    -- ^ Current input position.

  , Input -> ByteString
inputBytes    :: {-# UNPACK #-} !ByteString
    -- ^ The text that needs to be lexed.

  , Input -> SourcePos
inputPrev     :: {-# UNPACK #-} !SourcePos
    -- ^ Location of the last consumed character.

  , Input -> Word8
inputPrevByte :: {-# UNPACK #-} !Word8
    -- ^ The last consumed character.
  }

-- | Prepare the text for lexing.
initialInput :: Text {- ^ Where the text came from -} ->
                ByteString {- ^ The text to lex -} -> Input
initialInput :: Text -> ByteString -> Input
initialInput Text
file ByteString
str = Input
  { inputPos :: SourcePos
inputPos      = Text -> SourcePos
startPos Text
file
  , inputPrev :: SourcePos
inputPrev     = Text -> SourcePos
beforeStartPos Text
file
  , inputPrevByte :: Word8
inputPrevByte = Word8
0
  , inputBytes :: ByteString
inputBytes    = ByteString
str
  }

startPos :: Text {- ^ Name of file/thing containing this -} -> SourcePos
startPos :: Text -> SourcePos
startPos Text
file = SourcePos { sourceIndex :: Int
sourceIndex = Int
0, sourceFile :: Text
sourceFile = Text
file }

beforeStartPos :: Text -> SourcePos
beforeStartPos :: Text -> SourcePos
beforeStartPos Text
file = SourcePos { sourceIndex :: Int
sourceIndex = -Int
1, sourceFile :: Text
sourceFile = Text
file }

{- | Move one position back.  Assumes that newlines use a single bytes.

This function is intended to be used when starting the lexing somewhere
in the middle of the input, for example, if we are implementing a quasi
quoter, and the previous part of the input is not in our language.
-}
prevPos :: SourcePos -> SourcePos
prevPos :: SourcePos -> SourcePos
prevPos SourcePos
p
  | SourcePos -> Int
sourceIndex SourcePos
p forall a. Ord a => a -> a -> Bool
< Int
0 = SourcePos
p
  | Bool
otherwise         = SourcePos
p { sourceIndex :: Int
sourceIndex = SourcePos -> Int
sourceIndex SourcePos
p forall a. Num a => a -> a -> a
- Int
1 }

-- | The file/thing for the current position.
inputFile :: Input -> Text
inputFile :: Input -> Text
inputFile = SourcePos -> Text
sourceFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> SourcePos
inputPos

--------------------------------------------------------------------------------
-- | Lexer configuration.
data LexerConfig s t = LexerConfig
  { forall s t. LexerConfig s t -> s
lexerInitialState :: s
    -- ^ State that the lexer starts in

  , forall s t. LexerConfig s t -> s -> Int
lexerStateMode :: s -> Int
    -- ^ Determine the current lexer mode from the lexer's state.

  , forall s t. LexerConfig s t -> s -> SourcePos -> [Lexeme t]
lexerEOF       :: s -> SourcePos -> [Lexeme t]
    -- ^ Emit some lexemes at the end of the input.
  }

-- | A lexer that uses no lexer-modes, and does not emit anything at the
-- end of the file.
simpleLexer :: LexerConfig () t
simpleLexer :: forall t. LexerConfig () t
simpleLexer = LexerConfig
  { lexerInitialState :: ()
lexerInitialState = ()
  , lexerStateMode :: () -> Int
lexerStateMode    = \()
_ -> Int
0
  , lexerEOF :: () -> SourcePos -> [Lexeme t]
lexerEOF          = \()
_ SourcePos
_ -> []
  }


-- | Generate a function to use an Alex lexer.
-- The expression is of type @LexerConfig s t -> Input -> [Lexeme t]@
makeLexer :: ExpQ
makeLexer :: ExpQ
makeLexer =
  do let local :: Q (Q Pat, ExpQ)
local = do Name
n <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
                    forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
n)

     ([Q Pat
xP,Q Pat
yP,Q Pat
zP], [ExpQ
xE,ExpQ
yE,ExpQ
zE]) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
3 Q (Q Pat, ExpQ)
local

     let -- Defined by Alex
         alexEOF :: Q Pat
alexEOF        = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName String
"AlexEOF")   [ ]
         alexError :: Q Pat
alexError      = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName String
"AlexError") [ forall (m :: * -> *). Quote m => m Pat
wildP ]
         alexSkip :: Q Pat
alexSkip       = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName String
"AlexSkip")  [ Q Pat
xP, forall (m :: * -> *). Quote m => m Pat
wildP ]
         alexToken :: Q Pat
alexToken      = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName String
"AlexToken") [ Q Pat
xP, Q Pat
yP, Q Pat
zP ]
         alexScanUser :: ExpQ
alexScanUser   = forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"alexScanUser")

     let m Pat
p ~> :: m Pat -> m Exp -> m Match
~> m Exp
e = forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match m Pat
p (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB m Exp
e) []
         body :: ExpQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ
body ExpQ
go ExpQ
mode ExpQ
inp ExpQ
cfg =
           forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE [| $alexScanUser $mode $inp (lexerStateMode $cfg $mode) |]
             [ Q Pat
alexEOF   forall {m :: * -> *}. Quote m => m Pat -> m Exp -> m Match
~> [| lexerEOF $cfg $mode (inputPrev $inp) |]
             , Q Pat
alexError forall {m :: * -> *}. Quote m => m Pat -> m Exp -> m Match
~>
                  [| error "internal error in lexer (AlexToolsBin.hs)" |]
             , Q Pat
alexSkip  forall {m :: * -> *}. Quote m => m Pat -> m Exp -> m Match
~> [| $go $mode $xE |]
             , Q Pat
alexToken forall {m :: * -> *}. Quote m => m Pat -> m Exp -> m Match
~> [| case runA $zE $inp $xE $yE $mode of
                                 (mode', ts) -> ts ++ $go mode' $xE |]
             ]

     [e| \cfg -> let go mode inp = $(body [|go|] [|mode|] [|inp|] [|cfg|])
                 in go (lexerInitialState cfg) |]

type AlexInput = Input

{-# INLINE alexInputPrevChar #-}
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar :: Input -> Char
alexInputPrevChar = forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Word8
inputPrevByte

{-# INLINE alexGetByte #-}
alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
alexGetByte :: Input -> Maybe (Word8, Input)
alexGetByte Input
inp =
  do (Word8
b,ByteString
bs) <- ByteString -> Maybe (Word8, ByteString)
BS.uncons (Input -> ByteString
inputBytes Input
inp)
     let inp1 :: Input
inp1 = Input { inputPrev :: SourcePos
inputPrev     = Input -> SourcePos
inputPos Input
inp
                      , inputPrevByte :: Word8
inputPrevByte = Word8
b
                      , inputPos :: SourcePos
inputPos      = SourcePos -> SourcePos
moveSourcePos (Input -> SourcePos
inputPos Input
inp)
                      , inputBytes :: ByteString
inputBytes    = ByteString
bs
                      }
     Input
inp1 seq :: forall a b. a -> b -> b
`seq` forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8
b,Input
inp1)