{
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)

}