{
{-# OPTIONS -w #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Virgil.Lexer where
import Control.Monad (liftM)
import Data.Monoid ((<>))
import Data.Scientific
import Data.Text (Text)
import qualified Data.Text as T
import Prelude hiding (lex)
}
%wrapper "monadUserState"
$digit = 0-9
$alpha = [A-Za-z]
@int = $digit+
@exp = [Ee] [\-\+]? @int
@frac = @int \. @int @exp? | @int @exp
@sign = \-?
@str = \"[^\"]*\"
tokens :-
$white+ ;
"#".* ;
@sign @int \. @int { lex (float True False) }
@sign @int \. @int @exp { lex (float True True) }
@sign @int @exp { lex (float False True) }
@sign @int { lex (TkInt . read . T.unpack) }
@str { lex strLiteral }
with { lex' (TkKw KwWith) }
true { lex' (TkKw KwTrue) }
false { lex' (TkKw KwFalse) }
null { lex' (TkKw KwNull) }
\{ { lex' TkLCurl }
\} { lex' TkRCurl }
\[ { lex' TkLBrac }
\] { lex' TkRBrac }
\( { lex' TkLParn }
\) { lex' TkRParn }
\: { lex' TkColon }
\; { lex' TkSemi }
\, { lex' TkComma }
{
data Token = Token AlexPosn TkType deriving (Eq, Show)
data KwType
= KwTrue
| KwFalse
| KwNull
| KwWith
deriving (Eq, Show)
data TkType
= TkInt Integer
| TkFloat Scientific
| TkStr Text
| TkKw KwType
| TkColon
| TkSemi
| TkLCurl
| TkRCurl
| TkLBrac
| TkRBrac
| TkLParn
| TkRParn
| TkComma
| TkEOF
deriving (Eq, Show)
-- Parsing floats with exponents and whatnot
-- XXX: MAKE MORE EFFICIENT AND LESS GROSS
float :: Bool -> Bool -> Text -> TkType
float False False _ = error "[unreachable]"
float True False t = -- dot but not exponent
let [a,b] = T.splitOn "." t
in TkFloat (scientific (read (T.unpack (a <> b))) (negate (T.length b)))
float False True t = -- exponent but no dot
let [a,e] = if T.any (== 'e') t
then T.splitOn "e" t
else T.splitOn "E" t
in TkFloat (scientific (read (T.unpack a)) (read (T.unpack e)))
float True True t = -- exponent and dot
let [t',e] = if T.any (== 'e') t
then T.splitOn "e" t
else T.splitOn "E" t
[a, b] = T.splitOn "." t'
in TkFloat (scientific (read (T.unpack (a <> b)))
(negate (T.length b) + read (T.unpack e)))
strLiteral :: Text -> TkType
strLiteral = TkStr . T.drop 1 . T.dropEnd 1
data AlexUserState = AlexUserState
{ filePath :: FilePath
} deriving (Eq, Show)
alexInitUserState :: AlexUserState
alexInitUserState = AlexUserState "<unknown>"
getFilePath :: Alex FilePath
getFilePath = liftM filePath alexGetUserState
setFilePath :: FilePath -> Alex ()
setFilePath = alexSetUserState . AlexUserState
alexMonadScan' :: Alex Token
alexMonadScan' = do
inp <- alexGetInput
sc <- alexGetStartCode
case alexScan inp sc of
AlexEOF -> alexEOF
AlexError (p, _, _, s) ->
alexError' p ("lexical error at character '" ++ take 1 s ++ "'")
AlexSkip inp' len -> do
alexSetInput inp'
alexMonadScan'
AlexToken inp' len action -> do
alexSetInput inp'
action (ignorePendingBytes inp) len
alexError' :: AlexPosn -> String -> Alex a
alexError' (AlexPn _ l c) msg = do
fp <- getFilePath
alexError (fp ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
alexEOF :: Alex Token
alexEOF = do
(p,_,_,_) <- alexGetInput
return (Token p TkEOF)
lex :: (Text -> TkType) -> AlexAction Token
lex f = \(p,_,_,s) i -> return (Token p (f (T.pack (take i s))))
lex' :: TkType -> AlexAction Token
lex' = lex . const
runAlex' :: Alex a -> FilePath -> String -> Either String a
runAlex' mote fp input = runAlex input (setFilePath fp >> mote)
}