amelia
/
cubical


{

module Presyntax.Lexer where


import qualified Data.ByteString.Lazy as Lbs

import qualified Data.Text.Encoding as T

import qualified Data.Text as T


import Presyntax.Tokens


import Debug.Trace


}


%wrapper "monadUserState-bytestring"


$alpha = [a-zA-Z]

$digit = [0-9]

$white_nol = $white # \n


tokens :-

 $white_nol+ ;

 "--" .* \n ;


<0,prtext> $alpha [$alpha $digit \_ \']* { variableOrKeyword }


-- zero state: normal lexing

<0> \= { always TokEqual }

<0> \: { always TokColon }

<0> \, { always TokComma }

<0> \* { always TokStar }


<0> ".1" { always TokPi1 }

<0> ".2" { always TokPi2 }


<0> \\ { always TokLambda }

<0> "->" { always TokArrow }

<0> "_" { always TokUnder }


<0> \( { always TokOParen }

<0> \{ { always TokOBrace }

<0> \[ { always TokOSquare }


<0> \) { always TokCParen }

<0> \} { closeBrace }

<0> \] { always TokCSquare }


<0> \; { always TokSemi }


<0> \n { just $ pushStartCode newline }


<0> "&&" { always TokAnd }

<0> "||" { always TokOr }


<0> "{-" { just $ pushStartCode comment }


<comment> {

 "-}" { \i l -> popStartCode *> skip i l }

 . ;

}


<0> "{-#" { \i l -> pushStartCode prkw *> always TokOPragma i l }

<prkw> "PRIMITIVE" { \i l -> popStartCode *> pushStartCode prtext *> always TokPrim i l }

<prtext> "#-}" { \i l -> popStartCode *> always TokCPragma i l }


<0> ":let" { always TokReplLet }

<0> ":t"("y"|"yp"|"ype"|()) { yield TokReplT }


-- newline: emit a semicolon when de-denting

<newline> {

 \n ;

 () { offsideRule }

}


-- layout: indentation of the next token is context for offside rule

<layout> {

 \n ;

 \{ { openBrace }

 () { startLayout }

}


<empty_layout> () { emptyLayout }


{

alexEOF :: Alex Token

alexEOF = do

 (AlexPn _ l c, _, _, _) <- alexGetInput

 pure $ Token TokEof l c


yield k (AlexPn _ l c, _, s, _) i = pure (Token (k $! (T.decodeUtf8 (Lbs.toStrict (Lbs.take i s)))) l c)


always :: TokenClass -> AlexInput -> Int64 -> Alex Token

always k x i = yield (const k) x i


data AlexUserState = AlexUserState { layoutColumns :: [Int], startCodes :: [Int], leastColumn :: Int }

alexInitUserState = AlexUserState [1] [] 0


just :: Alex a -> AlexAction Token

just k _ _ = k *> alexMonadScan


getUserState :: Alex AlexUserState

getUserState = Alex $ \s -> Right (s, alex_ust s)


mapUserState :: (AlexUserState -> AlexUserState) -> Alex ()

mapUserState k = Alex $ \s -> Right (s { alex_ust = k $! alex_ust s }, ())


pushStartCode :: Int -> Alex ()

pushStartCode c = do

 sc <- alexGetStartCode

 mapUserState $ \s -> s { startCodes = sc:startCodes s }

 alexSetStartCode c


popStartCode :: Alex ()

popStartCode = do

 sc <- startCodes <$> getUserState

 case sc of

 [] -> alexSetStartCode 0

 (x:xs) -> do

 mapUserState $ \s -> s { startCodes = xs }

 alexSetStartCode x


offsideRule :: AlexInput -> Int64 -> Alex Token

offsideRule (AlexPn _ line col, _, _, _) _

-- | Lbs.null s = pure (Token TokEof line col)

 | otherwise = do

 ~(col':ctx) <- layoutColumns <$> getUserState

 case col `compare` col' of

 EQ -> do

 popStartCode

 pure (Token TokSemi line col)

 GT -> do

 popStartCode

 alexMonadScan

 LT -> do

 mapUserState $ \s -> s { layoutColumns = ctx }

 pure (Token TokLEnd line col)


emptyLayout :: AlexInput -> Int64 -> Alex Token

emptyLayout (AlexPn _ line col, _, _, _) _ = do

 popStartCode

 pushStartCode newline

 pure (Token TokLEnd line col)


startLayout :: AlexInput -> Int64 -> Alex Token

startLayout (AlexPn _ line col, _, _, _) _ = do

 popStartCode

 ~(col':_) <- layoutColumns <$> getUserState

 if col' >= col

 then pushStartCode empty_layout

 else mapUserState $ \s -> s { layoutColumns = col:layoutColumns s }

 pure (Token TokLStart line col)


openBrace :: AlexInput -> Int64 -> Alex Token

openBrace (AlexPn _ line col, _, _, _) _ = do

 popStartCode

 mapUserState $ \s -> s { layoutColumns = minBound:layoutColumns s }

 pure (Token TokOBrace line col)


closeBrace :: AlexInput -> Int64 -> Alex Token

closeBrace (AlexPn _ line col, _, _, _) _ = do

 ~(col':tail) <- layoutColumns <$> getUserState

 if col' < 0

 then mapUserState $ \s -> s { layoutColumns = tail }

 else pure ()

 pure (Token TokCBrace line col)


variableOrKeyword :: AlexAction Token

variableOrKeyword (AlexPn _ l c, _, s, _) size =

 let text = T.decodeUtf8 (Lbs.toStrict (Lbs.take size s)) in

 case T.unpack text of

 "as" -> pure (Token TokAs l c)

 "in" -> pure (Token TokIn l c)

 "data" -> pure (Token TokData l c)


 "postulate" -> laidOut TokPostulate l c

 "let" -> laidOut TokLet l c

 "where" -> laidOut TokWhere l c

 "case" -> laidOut TokCase l c


 _ -> pure (Token (TokVar text) l c)


laidOut x l c = do

 pushStartCode layout

 mapUserState $ \s -> s { leastColumn = c }

 pure (Token x l c)


}