Initial data commit
This commit is contained in:
Ingy döt Net
parent
72d218235f
commit
f23f22d71c
199087 changed files with 3378941 additions and 0 deletions
|
|
@ -0,0 +1,304 @@
|
|||
import Control.Applicative hiding (many, some)
|
||||
import Control.Monad.State.Lazy
|
||||
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
|
||||
import Data.Char (isAsciiLower, isAsciiUpper, isDigit, ord)
|
||||
import Data.Foldable (asum)
|
||||
import Data.Functor (($>))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Prelude hiding (lex)
|
||||
import System.Environment (getArgs)
|
||||
import System.IO
|
||||
import Text.Printf
|
||||
|
||||
|
||||
-- Tokens --------------------------------------------------------------------------------------------------------------
|
||||
data Val = IntVal Int -- value
|
||||
| TextVal String Text -- name value
|
||||
| SymbolVal String -- name
|
||||
| Skip
|
||||
| LexError String -- message
|
||||
|
||||
data Token = Token Val Int Int -- value line column
|
||||
|
||||
|
||||
instance Show Val where
|
||||
show (IntVal value) = printf "%-18s%d\n" "Integer" value
|
||||
show (TextVal "String" value) = printf "%-18s%s\n" "String" (show $ T.unpack value) -- show escaped characters
|
||||
show (TextVal name value) = printf "%-18s%s\n" name (T.unpack value)
|
||||
show (SymbolVal name ) = printf "%s\n" name
|
||||
show (LexError msg ) = printf "%-18s%s\n" "Error" msg
|
||||
show Skip = printf ""
|
||||
|
||||
instance Show Token where
|
||||
show (Token val line column) = printf "%2d %2d %s" line column (show val)
|
||||
|
||||
|
||||
printTokens :: [Token] -> String
|
||||
printTokens tokens =
|
||||
"Location Token name Value\n" ++
|
||||
"--------------------------------------\n" ++
|
||||
(concatMap show tokens)
|
||||
|
||||
|
||||
-- Tokenizers ----------------------------------------------------------------------------------------------------------
|
||||
makeToken :: Lexer Val -> Lexer Token
|
||||
makeToken lexer = do
|
||||
(t, l, c) <- get
|
||||
val <- lexer
|
||||
|
||||
case val of
|
||||
Skip -> nextToken
|
||||
|
||||
LexError msg -> do
|
||||
(_, l', c') <- get
|
||||
|
||||
let code = T.unpack $ T.take (c' - c + 1) t
|
||||
let str = printf "%s\n%s(%d, %d): %s" msg (replicate 27 ' ') l' c' code
|
||||
|
||||
ch <- peek
|
||||
unless (ch == '\0') $ advance 1
|
||||
|
||||
return $ Token (LexError str) l c
|
||||
|
||||
_ -> return $ Token val l c
|
||||
|
||||
|
||||
simpleToken :: String -> String -> Lexer Val
|
||||
simpleToken lexeme name = lit lexeme $> SymbolVal name
|
||||
|
||||
|
||||
makeTokenizers :: [(String, String)] -> Lexer Val
|
||||
makeTokenizers = asum . map (uncurry simpleToken)
|
||||
|
||||
|
||||
keywords :: Lexer Val
|
||||
keywords = makeTokenizers
|
||||
[("if", "Keyword_if"), ("else", "Keyword_else"), ("while", "Keyword_while"),
|
||||
("print", "Keyword_print"), ("putc", "Keyword_putc")]
|
||||
|
||||
|
||||
operators :: Lexer Val
|
||||
operators = makeTokenizers
|
||||
[("*", "Op_multiply"), ("/", "Op_divide"), ("%", "Op_mod"), ("+", "Op_add"),
|
||||
("-", "Op_subtract"), ("<=", "Op_lessequal"), ("<", "Op_less"), (">=", "Op_greaterequal"),
|
||||
(">", "Op_greater"), ("==", "Op_equal"), ("!=", "Op_notequal"), ("!", "Op_not"),
|
||||
("=", "Op_assign"), ("&&", "Op_and"), ("||", "Op_or")]
|
||||
|
||||
|
||||
symbols :: Lexer Val
|
||||
symbols = makeTokenizers
|
||||
[("(", "LeftParen"), (")", "RightParen"),
|
||||
("{", "LeftBrace"), ("}", "RightBrace"),
|
||||
(";", "Semicolon"), (",", "Comma")]
|
||||
|
||||
|
||||
isIdStart :: Char -> Bool
|
||||
isIdStart ch = isAsciiLower ch || isAsciiUpper ch || ch == '_'
|
||||
|
||||
isIdEnd :: Char -> Bool
|
||||
isIdEnd ch = isIdStart ch || isDigit ch
|
||||
|
||||
identifier :: Lexer Val
|
||||
identifier = TextVal "Identifier" <$> lexeme
|
||||
where lexeme = T.cons <$> (one isIdStart) <*> (many isIdEnd)
|
||||
|
||||
|
||||
integer :: Lexer Val
|
||||
integer = do
|
||||
lexeme <- some isDigit
|
||||
next_ch <- peek
|
||||
|
||||
if (isIdStart next_ch) then
|
||||
return $ LexError "Invalid number. Starts like a number, but ends in non-numeric characters."
|
||||
else do
|
||||
let num = read (T.unpack lexeme) :: Int
|
||||
return $ IntVal num
|
||||
|
||||
|
||||
character :: Lexer Val
|
||||
character = do
|
||||
lit "'"
|
||||
str <- lookahead 3
|
||||
|
||||
case str of
|
||||
(ch : '\'' : _) -> advance 2 $> IntVal (ord ch)
|
||||
"\\n'" -> advance 3 $> IntVal 10
|
||||
"\\\\'" -> advance 3 $> IntVal 92
|
||||
('\\' : ch : "\'") -> advance 2 $> LexError (printf "Unknown escape sequence \\%c" ch)
|
||||
('\'' : _) -> return $ LexError "Empty character constant"
|
||||
_ -> advance 2 $> LexError "Multi-character constant"
|
||||
|
||||
|
||||
string :: Lexer Val
|
||||
string = do
|
||||
lit "\""
|
||||
|
||||
loop (T.pack "") =<< peek
|
||||
where loop t ch = case ch of
|
||||
'\\' -> do
|
||||
next_ch <- next
|
||||
|
||||
case next_ch of
|
||||
'n' -> loop (T.snoc t '\n') =<< next
|
||||
'\\' -> loop (T.snoc t '\\') =<< next
|
||||
_ -> return $ LexError $ printf "Unknown escape sequence \\%c" next_ch
|
||||
|
||||
'"' -> next $> TextVal "String" t
|
||||
|
||||
'\n' -> return $ LexError $ "End-of-line while scanning string literal." ++
|
||||
" Closing string character not found before end-of-line."
|
||||
|
||||
'\0' -> return $ LexError $ "End-of-file while scanning string literal." ++
|
||||
" Closing string character not found."
|
||||
|
||||
_ -> loop (T.snoc t ch) =<< next
|
||||
|
||||
|
||||
skipComment :: Lexer Val
|
||||
skipComment = do
|
||||
lit "/*"
|
||||
|
||||
loop =<< peek
|
||||
where loop ch = case ch of
|
||||
'\0' -> return $ LexError "End-of-file in comment. Closing comment characters not found."
|
||||
|
||||
'*' -> do
|
||||
next_ch <- next
|
||||
|
||||
case next_ch of
|
||||
'/' -> next $> Skip
|
||||
_ -> loop next_ch
|
||||
|
||||
_ -> loop =<< next
|
||||
|
||||
|
||||
nextToken :: Lexer Token
|
||||
nextToken = do
|
||||
skipWhitespace
|
||||
|
||||
makeToken $ skipComment
|
||||
<|> keywords
|
||||
<|> identifier
|
||||
<|> integer
|
||||
<|> character
|
||||
<|> string
|
||||
<|> operators
|
||||
<|> symbols
|
||||
<|> simpleToken "\0" "End_of_input"
|
||||
<|> (return $ LexError "Unrecognized character.")
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
(hin, hout) <- getIOHandles args
|
||||
|
||||
withHandles hin hout $ printTokens . (lex nextToken)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Machinery
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
-- File handling -------------------------------------------------------------------------------------------------------
|
||||
getIOHandles :: [String] -> IO (Handle, Handle)
|
||||
getIOHandles [] = return (stdin, stdout)
|
||||
|
||||
getIOHandles [infile] = do
|
||||
inhandle <- openFile infile ReadMode
|
||||
return (inhandle, stdout)
|
||||
|
||||
getIOHandles (infile : outfile : _) = do
|
||||
inhandle <- openFile infile ReadMode
|
||||
outhandle <- openFile outfile WriteMode
|
||||
return (inhandle, outhandle)
|
||||
|
||||
|
||||
withHandles :: Handle -> Handle -> (String -> String) -> IO ()
|
||||
withHandles in_handle out_handle f = do
|
||||
contents <- hGetContents in_handle
|
||||
let contents' = contents ++ "\0" -- adding \0 simplifies treatment of EOF
|
||||
|
||||
hPutStr out_handle $ f contents'
|
||||
|
||||
unless (in_handle == stdin) $ hClose in_handle
|
||||
unless (out_handle == stdout) $ hClose out_handle
|
||||
|
||||
|
||||
-- Lexer ---------------------------------------------------------------------------------------------------------------
|
||||
type LexerState = (Text, Int, Int) -- input line column
|
||||
type Lexer = MaybeT (State LexerState)
|
||||
|
||||
|
||||
lexerAdvance :: Int -> LexerState -> LexerState
|
||||
lexerAdvance 0 ctx = ctx
|
||||
|
||||
lexerAdvance 1 (t, l, c)
|
||||
| ch == '\n' = (rest, l + 1, 1 )
|
||||
| otherwise = (rest, l, c + 1)
|
||||
where
|
||||
(ch, rest) = (T.head t, T.tail t)
|
||||
|
||||
lexerAdvance n ctx = lexerAdvance (n - 1) $ lexerAdvance 1 ctx
|
||||
|
||||
|
||||
advance :: Int -> Lexer ()
|
||||
advance n = modify $ lexerAdvance n
|
||||
|
||||
|
||||
peek :: Lexer Char
|
||||
peek = gets $ \(t, _, _) -> T.head t
|
||||
|
||||
|
||||
lookahead :: Int -> Lexer String
|
||||
lookahead n = gets $ \(t, _, _) -> T.unpack $ T.take n t
|
||||
|
||||
|
||||
next :: Lexer Char
|
||||
next = advance 1 >> peek
|
||||
|
||||
|
||||
skipWhitespace :: Lexer ()
|
||||
skipWhitespace = do
|
||||
ch <- peek
|
||||
when (ch `elem` " \n") (next >> skipWhitespace)
|
||||
|
||||
|
||||
lit :: String -> Lexer ()
|
||||
lit lexeme = do
|
||||
(t, _, _) <- get
|
||||
guard $ T.isPrefixOf (T.pack lexeme) t
|
||||
advance $ length lexeme
|
||||
|
||||
|
||||
one :: (Char -> Bool) -> Lexer Char
|
||||
one f = do
|
||||
ch <- peek
|
||||
guard $ f ch
|
||||
next
|
||||
return ch
|
||||
|
||||
|
||||
lexerMany :: (Char -> Bool) -> LexerState -> (Text, LexerState)
|
||||
lexerMany f (t, l, c) = (lexeme, (t', l', c'))
|
||||
where (lexeme, _) = T.span f t
|
||||
(t', l', c') = lexerAdvance (T.length lexeme) (t, l, c)
|
||||
|
||||
|
||||
many :: (Char -> Bool) -> Lexer Text
|
||||
many f = state $ lexerMany f
|
||||
|
||||
|
||||
some :: (Char -> Bool) -> Lexer Text
|
||||
some f = T.cons <$> (one f) <*> (many f)
|
||||
|
||||
|
||||
lex :: Lexer a -> String -> [a]
|
||||
lex lexer str = loop lexer (T.pack str, 1, 1)
|
||||
where loop lexer s
|
||||
| T.null txt = [t]
|
||||
| otherwise = t : loop lexer s'
|
||||
|
||||
where (Just t, s') = runState (runMaybeT lexer) s
|
||||
(txt, _, _) = s'
|
||||
Loading…
Add table
Add a link
Reference in a new issue