diff --git a/test.sh b/test.sh new file mode 100755 index 0000000..af56488 --- /dev/null +++ b/test.sh @@ -0,0 +1,38 @@ +#!/usr/bin/env zsh + +typeset -a listfic +if (($#==0)); then + listfic=( tests/*(.N) ) +else + for arg in $@; do + listfic=( $listfic tests/$arg ) + done +fi + +tmpfic=tests/tmp +for input in $listfic; do + sed 's/\\/\\\\/g' $input > $tmpfic + # set 3 as the file descriptor for the file $tmpfic + exec 3< $tmpfic + done=0 + num=1 + until ((done == 1)); do + read <&3 program + (($?!=0)) && {done=1;continue} + read <&3 expected + (($?!=0)) && {done=1;continue} + result="$(runghc y.hs "$program")" + printf "%18s (line %3d): " ${input:t} $num + if [[ $expected == $result ]]; then + print -- "OK" + else + print -- "ERROR" + print -- " program: '$program'" + print -- " expected: '$expected'" + print -- " got: '$result'" + print -- "" + fi + ((num+=2)) + done +done +\rm -f $tmpfic diff --git a/tests/binarynumber b/tests/binarynumber new file mode 100644 index 0000000..17e13e6 --- /dev/null +++ b/tests/binarynumber @@ -0,0 +1,6 @@ +32 +32 +#x012 +18 +#b001010 +10 diff --git a/tests/char b/tests/char new file mode 100644 index 0000000..eff905d --- /dev/null +++ b/tests/char @@ -0,0 +1,2 @@ +#\a +'a' diff --git a/tests/float b/tests/float new file mode 100644 index 0000000..066db4f --- /dev/null +++ b/tests/float @@ -0,0 +1,2 @@ +3.14 +3.14 diff --git a/tests/list b/tests/list new file mode 100644 index 0000000..e69de29 diff --git a/tests/number b/tests/number new file mode 100644 index 0000000..fc40ae5 --- /dev/null +++ b/tests/number @@ -0,0 +1,2 @@ +32 +32 diff --git a/tests/string b/tests/string new file mode 100644 index 0000000..a600a7d --- /dev/null +++ b/tests/string @@ -0,0 +1,6 @@ +"This is a simple string" +"This is a simple string" +"A tab ->\t<- Here" +"A tab -> <- Here" +"\S\o\m\e\ \pr\ot\e\ct\e\d\ \w\it\h\ \\" +"Some protected with \" diff --git a/y.hs b/y.hs new file mode 100644 index 0000000..17c0552 --- /dev/null +++ b/y.hs @@ -0,0 +1,185 @@ +module Main where + +import Control.Monad (liftM) +import Data.List (foldl') +import Text.ParserCombinators.Parsec hiding (spaces) +import System.Environment (getArgs) + +-- The possible LISP values +data LispVal = Atom String + | List [LispVal] + | DottedList [LispVal] LispVal + | Float Float + | Number Integer + | Character Char + | String String + | Bool Bool + +-- The program (in IO) +-- execute the arguments given in parameters +main :: IO () +main = getArgs >>= print . eval . readExpr . head + +-- ReadExpr will take a program as input +-- and will return the result of a parseExpr +readExpr :: String -> LispVal +readExpr input = case parse parseExpr "lisp" input of + Left err -> String $ "No match: " ++ show err + Right val -> val + +showVal :: LispVal -> String +showVal (String contents) = "\"" ++ contents ++ "\"" +showVal (Atom name) = name +showVal (Number contents) = show contents +showVal (Float contents) = show contents +showVal (Character c) = '\'':c:'\'':[] +showVal (Bool True) = "#t" +showVal (Bool False) = "#f" +showVal (List contents) = "(" ++ unwordsList contents ++ ")" +showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")" + +unwordsList :: [LispVal] -> String +unwordsList = unwords . map showVal + +instance Show LispVal where show = showVal + +-- parseExpr will parse the Expression +parseExpr :: Parser LispVal +parseExpr = parseString + <|> try parseChar -- #\a #\b etc... + <|> try parseFloat -- 3.1415 + <|> parseNumber -- 3, #b011001, #o070, #d930, #xFF3 + <|> parseAtom -- symbol-323 + <|> parseQuoted + <|> do + char '(' + x <- try parseList <|> parseDottedList + char ')' + return x + +symbol :: Parser Char +symbol = oneOf "!#$%&|*+-/:<=>?@^_~" + +spaces :: Parser () +spaces = skipMany1 space + +parseChar :: Parser LispVal +parseChar = do + string "#\\" + c <- anyChar + return $ Character c + +parseString :: Parser LispVal +parseString = do + char '"' + x <- many $ strSpecialChar <|> noneOf "\"" + char '"' + return $ String x + where + strSpecialChar = char '\\' >> do + x <- anyChar + case x of + 'n' -> return '\n' + 't' -> return '\t' + 'r' -> return '\r' + _ -> return x + +parseAtom :: Parser LispVal +parseAtom = do + first <- letter <|> symbol + rest <- many (letter <|> digit <|> symbol) + let atom = first:rest + return $ case atom of + "#vrai" -> Bool True + "#faux" -> Bool False + _ -> Atom atom + +numFromBase n str = foldl' traiteNombre 0 str + where + traiteNombre acc v = acc*n + chiffre + where chiffre = case v of + '0' -> 0 + '1' -> 1 + '2' -> 2 + '3' -> 3 + '4' -> 4 + '5' -> 5 + '6' -> 6 + '7' -> 7 + '8' -> 8 + '9' -> 9 + 'A' -> 10 + 'B' -> 11 + 'C' -> 12 + 'D' -> 13 + 'E' -> 14 + 'F' -> 15 + 'a' -> 10 + 'b' -> 11 + 'c' -> 12 + 'd' -> 13 + 'e' -> 14 + 'f' -> 15 + +parseBaseSpecifiedNumber :: Parser Integer +parseBaseSpecifiedNumber = do + _ <- char '#' + numtype <- oneOf "bdox" + (base,str) <- case numtype of + 'b' -> do + numstr <- many1 (oneOf "01") + return (2,numstr) + 'o' -> do + numstr <- many1 (oneOf "01234567") + return (8,numstr) + 'd' -> do + numstr <- many1 (oneOf "0123456789") + return (10,numstr) + 'x' -> do + numstr <- many1 (oneOf "0123456789ABCDEFabcdef") + return (16,numstr) + return $ numFromBase base str + +parseSimpleNumber :: Parser Integer +parseSimpleNumber = do + numStr <- many1 digit + return (read numStr) + +parseFloat :: Parser LispVal +parseFloat = do + numBeforeDot <- many1 digit + char '.' + numAfterDot <- many1 digit + return $ Float (read (numBeforeDot ++ "." ++ numAfterDot)) + +parseNumber :: Parser LispVal +parseNumber = do + number <- parseSimpleNumber + <|> parseBaseSpecifiedNumber + return (Number number) + +-- Recursive Parsers + +parseList :: Parser LispVal +parseList = liftM List $ sepBy parseExpr spaces + +parseDottedList :: Parser LispVal +parseDottedList = do + head <- endBy parseExpr spaces + tail <- char '.' >> spaces >> parseExpr + return $ DottedList head tail + +parseQuoted :: Parser LispVal +parseQuoted = do + char '\'' + x <- parseExpr + return $ List [Atom "quote", x] + +-- Evaluation +eval :: LispVal -> LispVal +eval val@(Character _) = val +eval val@(String _) = val +eval val@(Number _) = val +eval val@(Float _) = val +eval val@(Bool _) = val +eval (List [Atom "quote", val]) = val