amelia
/
ahc


module Frontend.Lexer.Wrapper where


import Control.Applicative as App (Applicative (..))


import qualified Data.ByteString.Internal as ByteString (w2c)

import qualified Data.ByteString.Lazy as ByteString

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.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 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, (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 (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

 }


alexInitUserState :: AlexUserState

alexInitUserState = AlexUserState [] [] 0 Nothing [] False T.empty Nothing Nothing