{
{-# LANGUAGE TemplateHaskell #-}

module Earthling.Lexer where

import           AlexTools
import qualified Data.Char as Char
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Read as T

}

$digit  = [0-9]
$letter = [A-Za-z]
$upper  = [A-Z]
$lower  = [a-z]
$op     = [\!\#\$\%\&\*\+\/\<\=\>\?\\\^\|\-\~]

@keyword = "@" [$lower] [$upper $lower _]+
@ident   = [$lower $op] [$upper $lower $digit $op _]*
@constr  = $upper [$upper $lower $digit $op _]*
@stackvar = "'" [$lower $op] [$upper $lower $digit $op _]*
@integer = [$digit]+
@double  = [$digit]+ \. [$digit]+

:-

<0> {

$white+ ;

"--" .* ;

"{-" ( ([^\-] | \n)* ("-"[^\}])? )* "-}" ;

"("  { structure SLParen }
")"  { structure SRParen }
"["  { structure SLBrac }
"]"  { structure SRBrac }
"{"  { structure SLCurl }
"}"  { structure SRCurl }
"."  { structure SDot }
"->" { structure SArrow }

@keyword  { doToken ret       TokKeyword }
@ident    { doToken ret       TokIdent }
@constr   { doToken ret       TokConstr }
@stackvar { doToken ret       TokStackVar }
@integer  { doToken T.decimal TokInt }
@double   { doToken T.double  TokDouble }

}

{

data Tok
  = TokKeyword  Text
  | TokIdent    Text
  | TokConstr   Text
  | TokInt      Integer
  | TokDouble   Double
  | TokStackVar Text
  | TokStructure Structure
    deriving (Eq, Show)

data Structure
  = SLParen
  | SRParen
  | SLBrac
  | SRBrac
  | SLCurl
  | SRCurl
  | SDot
  | SArrow
    deriving (Eq, Show)

structure :: Structure -> Action () [Lexeme Tok]
structure s = lexeme (TokStructure s)

ret :: T.Reader Text
ret t = return (t, mempty)

doToken :: (T.Reader a) -> (a -> Tok) -> Action () [Lexeme Tok]
doToken reader f = do
  t <- matchText
  case reader t of
    Right (res, _) -> lexeme (f res)
    Left err       -> error err

lexer :: Text -> [Lexeme Tok]
lexer str = $makeLexer simpleLexer input
  where input = (initialInput str) { inputPos = start }
        start = SourcePos 0 0 0

alexGetByte = makeAlexGetByte $ \ c ->
  if Char.isAscii c
     then toEnum (fromEnum c)
     else 0x1
}