|
module Frontend.Lexer.Wrapper where
|
|
|
|
import Control.Applicative as App (Applicative (..))
|
|
|
|
import Data.Word (Word8)
|
|
|
|
import Data.Int (Int64)
|
|
import qualified Data.Char
|
|
import qualified Data.ByteString.Lazy as ByteString
|
|
import qualified Data.ByteString.Internal as ByteString (w2c)
|
|
import Frontend.Lexer.Tokens (Token)
|
|
import qualified Data.Text as T
|
|
import Frontend.Parser.Posn
|
|
|
|
type Byte = Word8
|
|
type AlexInput = ( Posn, -- 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'))
|
|
|
|
-- -----------------------------------------------------------------------------
|
|
-- 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.
|
|
|
|
|
|
alexStartPos :: Posn
|
|
alexStartPos = Posn 1 1
|
|
|
|
alexMove :: Posn -> Char -> Posn
|
|
alexMove (Posn l c) '\t' = Posn l (c+8-((c-1) `mod` 8))
|
|
alexMove (Posn l _) '\n' = Posn (l+1) 1
|
|
alexMove (Posn l c) _ = Posn l (c+1)
|
|
|
|
data AlexState = AlexState {
|
|
alex_pos :: !Posn, -- 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
|
|
|
|
, alex_ust :: AlexUserState -- AlexUserState will be defined in the user program
|
|
, alex_fname :: String
|
|
}
|
|
|
|
runAlex :: String -> ByteString.ByteString -> Alex a -> Either ParseError a
|
|
runAlex fname input__ (Alex f) =
|
|
case f initState of
|
|
Left msg -> Left msg
|
|
Right ( _, a ) -> Right a
|
|
where
|
|
initState = AlexState
|
|
{ alex_bpos = 0
|
|
, alex_pos = alexStartPos
|
|
, alex_inp = input__
|
|
, alex_chr = '\n'
|
|
|
|
, alex_ust = alexInitUserState
|
|
|
|
, alex_scd = 0
|
|
, alex_fname = fname
|
|
}
|
|
|
|
newtype Alex a = Alex { unAlex :: AlexState -> Either ParseError (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_bpos=bpos,alex_chr=c,alex_inp=inp__} ->
|
|
Right (s, (pos,c,inp__,bpos))
|
|
|
|
|
|
alexSetInput :: AlexInput -> Alex ()
|
|
alexSetInput (pos,c,inp__,bpos)
|
|
= Alex $ \s -> Right ( s { alex_pos = pos
|
|
, alex_bpos = bpos
|
|
, alex_chr = c
|
|
, alex_inp = inp__
|
|
}
|
|
, ())
|
|
|
|
alexError :: String -> Alex a
|
|
alexError message = Alex $ \s -> Left (ParseError message (alex_fname s) Nothing (alex_pos s) (alex_pos s))
|
|
|
|
alexErrorPosn :: Posn -> Posn -> String -> Alex a
|
|
alexErrorPosn start end message = Alex $ \s -> Left (ParseError message (alex_fname s) Nothing start end)
|
|
|
|
alexThrow :: (String -> ParseError) -> Alex a
|
|
alexThrow err = Alex $ \s -> Left (err (alex_fname s))
|
|
|
|
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}, ())
|
|
|
|
-- -----------------------------------------------------------------------------
|
|
-- Useful token actions
|
|
|
|
type AlexAction result = AlexInput -> Int64 -> Alex result
|
|
|
|
-- 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)
|
|
|
|
data LayoutState
|
|
= LetLayout { layoutCol :: Int }
|
|
| Layout { layoutCol :: Int }
|
|
| ExplicitLayout
|
|
deriving (Show)
|
|
|
|
data AlexUserState =
|
|
AlexUserState { layoutColumns :: ![LayoutState]
|
|
, startCodes :: ![Int]
|
|
, leastColumn :: !Int
|
|
|
|
, pendingLayoutKw :: Maybe (Int -> LayoutState)
|
|
, pendingTokens :: ![Token]
|
|
, pendingLambdaCase :: !Bool
|
|
|
|
, stringBuffer :: !T.Text
|
|
, stringStartPosn :: Maybe Posn
|
|
}
|
|
|
|
alexInitUserState :: AlexUserState
|
|
alexInitUserState = AlexUserState [] [] 0 Nothing [] False T.empty Nothing
|
|
|
|
data ParseError
|
|
= ParseError { parseErrorMessage :: String
|
|
, parseErrorFilename :: String
|
|
, parseErrorInlineDesc :: Maybe String
|
|
, parseErrorBegin :: Posn
|
|
, parseErrorEnd :: Posn
|
|
}
|
|
deriving (Eq, Show)
|