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

    -- * Writing Lexer Actions
  , Action

    -- ** Lexemes
  , lexeme
  , matchLength
  , matchRange
  , matchText

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

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

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

  ) where

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

data Lexeme t = Lexeme
  { Lexeme t -> Text
lexemeText  :: !Text
  , Lexeme t -> t
lexemeToken :: !t
  , Lexeme t -> SourceRange
lexemeRange :: !SourceRange
  } deriving (Int -> Lexeme t -> ShowS
[Lexeme t] -> ShowS
Lexeme t -> String
(Int -> Lexeme t -> ShowS)
-> (Lexeme t -> String) -> ([Lexeme t] -> ShowS) -> Show (Lexeme t)
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
(Lexeme t -> Lexeme t -> Bool)
-> (Lexeme t -> Lexeme t -> Bool) -> Eq (Lexeme t)
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 Text
x t
y SourceRange
z) = (Text, t, SourceRange) -> ()
forall a. NFData a => a -> ()
rnf (Text
x,t
y,SourceRange
z)

data SourcePos = SourcePos
  { SourcePos -> Int
sourceIndex   :: !Int
  , SourcePos -> Int
sourceLine    :: !Int
  , SourcePos -> Int
sourceColumn  :: !Int
  , SourcePos -> Text
sourceFile    :: !Text
  } deriving (Int -> SourcePos -> ShowS
[SourcePos] -> ShowS
SourcePos -> String
(Int -> SourcePos -> ShowS)
-> (SourcePos -> String)
-> ([SourcePos] -> ShowS)
-> Show SourcePos
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
(SourcePos -> SourcePos -> Bool)
-> (SourcePos -> SourcePos -> Bool) -> Eq SourcePos
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, SourcePos -> Q Exp
SourcePos -> Q (TExp SourcePos)
(SourcePos -> Q Exp)
-> (SourcePos -> Q (TExp SourcePos)) -> Lift SourcePos
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: SourcePos -> Q (TExp SourcePos)
$cliftTyped :: SourcePos -> Q (TExp SourcePos)
lift :: SourcePos -> Q Exp
$clift :: SourcePos -> Q Exp
Lift)

-- | Pretty print the source position without the file name.
prettySourcePos :: SourcePos -> String
prettySourcePos :: SourcePos -> String
prettySourcePos SourcePos
x = Int -> String
forall a. Show a => a -> String
show (SourcePos -> Int
sourceLine SourcePos
x) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (SourcePos -> Int
sourceColumn 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) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++
  Int -> String
forall a. Show a => a -> String
show (SourcePos -> Int
sourceLine SourcePos
x) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++
  Int -> String
forall a. Show a => a -> String
show (SourcePos -> Int
sourceColumn SourcePos
x)




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

-- | Update a 'SourcePos' for a particular matched character
moveSourcePos :: Char -> SourcePos -> SourcePos
moveSourcePos :: Char -> SourcePos -> SourcePos
moveSourcePos Char
c SourcePos
p = SourcePos :: Int -> Int -> Int -> Text -> SourcePos
SourcePos { sourceIndex :: Int
sourceIndex  = SourcePos -> Int
sourceIndex SourcePos
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                              , sourceLine :: Int
sourceLine   = Int
newLine
                              , sourceColumn :: Int
sourceColumn = Int
newColumn
                              , sourceFile :: Text
sourceFile   = SourcePos -> Text
sourceFile SourcePos
p
                              }
  where
  line :: Int
line   = SourcePos -> Int
sourceLine SourcePos
p
  column :: Int
column = SourcePos -> Int
sourceColumn SourcePos
p

  (Int
newLine,Int
newColumn) = case Char
c of
                          Char
'\t' -> (Int
line, ((Int
column Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                          Char
'\n' -> (Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
1)
                          Char
_    -> (Int
line, Int
column Int -> Int -> Int
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
(Int -> SourceRange -> ShowS)
-> (SourceRange -> String)
-> ([SourceRange] -> ShowS)
-> Show SourceRange
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
(SourceRange -> SourceRange -> Bool)
-> (SourceRange -> SourceRange -> Bool) -> Eq SourceRange
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, SourceRange -> Q Exp
SourceRange -> Q (TExp SourceRange)
(SourceRange -> Q Exp)
-> (SourceRange -> Q (TExp SourceRange)) -> Lift SourceRange
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: SourceRange -> Q (TExp SourceRange)
$cliftTyped :: SourceRange -> Q (TExp SourceRange)
lift :: SourceRange -> Q Exp
$clift :: SourceRange -> Q Exp
Lift)

-- | 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) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"--" String -> ShowS
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== SourcePos -> Text
sourceFile SourcePos
pto =
    Text -> String
Text.unpack (SourcePos -> Text
sourceFile SourcePos
pfrom) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++
    SourcePos -> String
prettySourcePos SourcePos
pfrom String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"--" String -> ShowS
forall a. [a] -> [a] -> [a]
++
    SourcePos -> String
prettySourcePos SourcePos
pto
  | Bool
otherwise = SourcePos -> String
prettySourcePosLong SourcePos
pfrom String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"--" String -> ShowS
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 SourcePos
x SourcePos
y) = (SourcePos, SourcePos) -> ()
forall a. NFData a => a -> ()
rnf (SourcePos
x,SourcePos
y)

class HasRange t where
  range :: t -> SourceRange

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

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

instance HasRange (Lexeme t) where
  range :: Lexeme t -> SourceRange
range = Lexeme t -> SourceRange
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)  = a -> SourceRange
forall t. HasRange t => t -> SourceRange
range a
x
  range (Right b
x) = b -> SourceRange
forall t. HasRange t => t -> SourceRange
range b
x

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

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

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

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

instance Applicative (Action s) where
  pure :: a -> Action s a
pure a
a = (Input -> Input -> Int -> s -> (s, a)) -> Action s a
forall s a. (Input -> Input -> Int -> s -> (s, a)) -> Action s a
A (\Input
_ Input
_ Int
_ s
s -> (s
s,a
a))
  <*> :: Action s (a -> b) -> Action s a -> Action s 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 :: a -> Action s a
return = a -> Action s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  A Input -> Input -> Int -> s -> (s, a)
m >>= :: Action s a -> (a -> Action s b) -> Action s b
>>= a -> Action s b
f = (Input -> Input -> Int -> s -> (s, b)) -> Action s b
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 :: Action s Input
startInput = (Input -> Input -> Int -> s -> (s, Input)) -> Action s Input
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 :: Action s Input
endInput = (Input -> Input -> Int -> s -> (s, Input)) -> Action s Input
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 :: Action s Int
matchLength = (Input -> Input -> Int -> s -> (s, Int)) -> Action s Int
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 :: Action s s
getLexerState = (Input -> Input -> Int -> s -> (s, s)) -> Action s s
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 :: s -> Action s ()
setLexerState s
s = (Input -> Input -> Int -> s -> (s, ())) -> Action 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 :: Action s SourceRange
matchRange =
  do Input
i1 <- Action s Input
forall s. Action s Input
startInput
     Input
i2 <- Action s Input
forall s. Action s Input
endInput
     SourceRange -> Action s SourceRange
forall (m :: * -> *) a. Monad m => a -> m a
return (Input -> SourcePos
inputPos Input
i1 SourcePos -> SourcePos -> SourceRange
forall a b. (HasRange a, HasRange b) => a -> b -> SourceRange
<-> Input -> SourcePos
inputPrev Input
i2)

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

-- | Use the token and the current match to construct a lexeme.
lexeme :: t -> Action s [Lexeme t]
lexeme :: t -> Action s [Lexeme t]
lexeme t
tok =
  do SourceRange
r   <- Action s SourceRange
forall s. Action s SourceRange
matchRange
     Text
txt <- Action s Text
forall s. Action s Text
matchText
     let l :: Lexeme t
l = Lexeme :: forall t. Text -> t -> SourceRange -> Lexeme t
Lexeme { lexemeRange :: SourceRange
lexemeRange = SourceRange
r
                    , lexemeToken :: t
lexemeToken = t
tok
                    , lexemeText :: Text
lexemeText  = Text
txt
                    }
     Lexeme t
l Lexeme t -> Action s [Lexeme t] -> Action s [Lexeme t]
`seq` [Lexeme t] -> Action s [Lexeme t]
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 -> Text
inputText     :: {-# UNPACK #-} !Text
    -- ^ The text that needs to be lexed.

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

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

-- | Prepare the text for lexing.
initialInput :: Text {- ^ Where the text came from -} ->
                Text {- ^ The text to lex -} -> Input
initialInput :: Text -> Text -> Input
initialInput Text
file Text
str = Input :: SourcePos -> Text -> SourcePos -> Char -> Input
Input
  { inputPos :: SourcePos
inputPos      = Text -> SourcePos
startPos Text
file
  , inputPrev :: SourcePos
inputPrev     = Text -> SourcePos
beforeStartPos Text
file
  , inputPrevChar :: Char
inputPrevChar = Char
'\n'    -- end of the virtual previous line
  , inputText :: Text
inputText     = Text
str
  }

-- | Prepare the text for lexing, starting at a particular position.
-- This is useful when the document is not at the start of the file.
-- Since: 0.6
initialInputAt ::
  SourcePos {- ^ Starting poistion -} ->
  Text {- ^ The text to lex, not including any preceeding text -} ->
  Input
initialInputAt :: SourcePos -> Text -> Input
initialInputAt SourcePos
start Text
str = Input :: SourcePos -> Text -> SourcePos -> Char -> Input
Input
  { inputPos :: SourcePos
inputPos      = SourcePos
start
  , inputPrev :: SourcePos
inputPrev     = SourcePos
start { sourceIndex :: Int
sourceIndex   = SourcePos -> Int
sourceIndex SourcePos
start Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                          , sourceColumn :: Int
sourceColumn  = SourcePos -> Int
sourceColumn SourcePos
start Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                          }
  , inputPrevChar :: Char
inputPrevChar = Char
'\n'  -- just something
  , inputText :: Text
inputText     = Text
str
  }



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

beforeStartPos :: Text -> SourcePos
beforeStartPos :: Text -> SourcePos
beforeStartPos Text
file = SourcePos :: Int -> Int -> Int -> Text -> SourcePos
SourcePos { sourceIndex :: Int
sourceIndex   = -Int
1
                                , sourceLine :: Int
sourceLine    = Int
0
                                , sourceColumn :: Int
sourceColumn  = Int
0
                                , 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
sourceColumn SourcePos
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = SourcePos
p { sourceColumn :: Int
sourceColumn = SourcePos -> Int
sourceColumn SourcePos
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                           , sourceIndex :: Int
sourceIndex = SourcePos -> Int
sourceIndex SourcePos
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                           }

  | SourcePos -> Int
sourceLine SourcePos
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1   = SourcePos
p { sourceLine :: Int
sourceLine   = SourcePos -> Int
sourceLine SourcePos
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                           , sourceColumn :: Int
sourceColumn = Int
1
                           , sourceIndex :: Int
sourceIndex  = SourcePos -> Int
sourceIndex SourcePos
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                           }

  | Bool
otherwise          = Text -> SourcePos
beforeStartPos (SourcePos -> Text
sourceFile SourcePos
p)


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

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

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

  , 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 :: LexerConfig () t
simpleLexer = LexerConfig :: forall s t.
s
-> (s -> Int) -> (s -> SourcePos -> [Lexeme t]) -> LexerConfig s t
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 :: Q Exp
makeLexer =
  do let local :: Q (PatQ, Q Exp)
local = do Name
n <- String -> Q Name
newName String
"x"
                    (PatQ, Q Exp) -> Q (PatQ, Q Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> PatQ
varP Name
n, Name -> Q Exp
varE Name
n)

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

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

     let PatQ
p ~> :: PatQ -> Q Exp -> MatchQ
~> Q Exp
e = PatQ -> BodyQ -> [DecQ] -> MatchQ
match PatQ
p (Q Exp -> BodyQ
normalB Q Exp
e) []
         body :: Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp
body Q Exp
go Q Exp
mode Q Exp
inp Q Exp
cfg =
           Q Exp -> [MatchQ] -> Q Exp
caseE [| $alexScanUser $mode $inp (lexerStateMode $cfg $mode) |]
             [ PatQ
alexEOF   PatQ -> Q Exp -> MatchQ
~> [| lexerEOF $cfg $mode (inputPrev $inp) |]
             , PatQ
alexError PatQ -> Q Exp -> MatchQ
~> [| error "internal error in lexer (AlexTools.hs)" |]
             , PatQ
alexSkip  PatQ -> Q Exp -> MatchQ
~> [| $go $mode $xE |]
             , PatQ
alexToken PatQ -> Q Exp -> MatchQ
~> [| 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

alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar :: Input -> Char
alexInputPrevChar = Input -> Char
inputPrevChar

{-# INLINE makeAlexGetByte #-}
makeAlexGetByte :: (Char -> Word8) -> AlexInput -> Maybe (Word8,AlexInput)
makeAlexGetByte :: (Char -> Word8) -> Input -> Maybe (Word8, Input)
makeAlexGetByte Char -> Word8
charToByte Input { inputPos :: Input -> SourcePos
inputPos = SourcePos
p, inputText :: Input -> Text
inputText = Text
text } =
  do (Char
c,Text
text') <- Text -> Maybe (Char, Text)
Text.uncons Text
text
     let p' :: SourcePos
p'  = Char -> SourcePos -> SourcePos
moveSourcePos Char
c SourcePos
p
         x :: Word8
x   = Char -> Word8
charToByte Char
c
         inp :: Input
inp = Input :: SourcePos -> Text -> SourcePos -> Char -> Input
Input { inputPrev :: SourcePos
inputPrev     = SourcePos
p
                     , inputPrevChar :: Char
inputPrevChar = Char
c
                     , inputPos :: SourcePos
inputPos      = SourcePos
p'
                     , inputText :: Text
inputText     = Text
text'
                     }
     Word8
x Word8 -> Maybe (Word8, Input) -> Maybe (Word8, Input)
`seq` Input
inp Input -> Maybe (Word8, Input) -> Maybe (Word8, Input)
`seq` (Word8, Input) -> Maybe (Word8, Input)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8
x, Input
inp)