You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
177 lines
5.8 KiB
177 lines
5.8 KiB
module Frontend.Lexer.Wrapper where
|
|
|
|
import Control.Applicative as App (Applicative (..))
|
|
|
|
import qualified Data.Text.Lazy as Lt
|
|
import qualified Data.Text as T
|
|
import qualified Data.Char
|
|
import Data.Word (Word8)
|
|
import Data.Int (Int64)
|
|
|
|
import Errors
|
|
|
|
import Frontend.Lexer.Tokens (Token)
|
|
import Frontend.Lexer.Unicode
|
|
import Frontend.Parser.Posn
|
|
|
|
data AlexInput =
|
|
AI { aiPosn :: !Posn -- current position,
|
|
, aiChar :: !Char -- previous char
|
|
, aiInput :: !Lt.Text -- current input string
|
|
, aiRead :: !Int64 -- bytes consumed so far
|
|
}
|
|
|
|
ignorePendingBytes :: AlexInput -> AlexInput
|
|
ignorePendingBytes i = i -- no pending bytes when lexing bytestrings
|
|
|
|
alexInputPrevChar :: AlexInput -> Char
|
|
alexInputPrevChar = Data.Char.chr . fromIntegral . fudgeCharacterClass . classify . aiChar
|
|
|
|
alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
|
|
alexGetByte (AI p c cs n) = do
|
|
(char, cs') <- Lt.uncons cs
|
|
let byte
|
|
| char <= '\x7f' = fromIntegral (Data.Char.ord char)
|
|
| otherwise = fudgeCharacterClass (classify char)
|
|
p' = alexMove p char
|
|
n' = n+1
|
|
Just (byte, AI p' char 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 :: Lt.Text, -- 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 -> Lt.Text -> Alex a -> Either AhcError 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 AhcError (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, AI pos c inp__ bpos)
|
|
|
|
|
|
alexSetInput :: AlexInput -> Alex ()
|
|
alexSetInput (AI 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 (AhcError message (alex_fname s) Nothing (alex_pos s) (alex_pos s) [])
|
|
|
|
alexErrorPosn :: Posn -> Posn -> String -> Alex a
|
|
alexErrorPosn start end message = Alex $ \s -> Left (AhcError message (alex_fname s) Nothing start end [])
|
|
|
|
alexThrow :: (String -> AhcError) -> 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)
|
|
|
|
, lastToken :: !(Maybe Token)
|
|
, parenDepth :: !Int
|
|
}
|
|
|
|
alexInitUserState :: AlexUserState
|
|
alexInitUserState = AlexUserState [] [] 0 Nothing [] False T.empty Nothing Nothing 0
|