app/Main.hs

   1 module Main where
   2 import Control.Monad
   3 import Text.ParserCombinators.Parsec hiding (spaces)
   4 import System.Environment
   5 import Numeric
   6
   7 data LispVal = Atom String
   8              | List [LispVal]
   9              | DottedList [LispVal] LispVal
  10              | Number Integer
  11              | String String
  12              | Character Char
  13              | Bool Bool
  14
  15 symbol :: Parser Char
  16 symbol = oneOf "!#$%&|*+-/:<=>?@^_~"
  17
  18 spaces :: Parser ()
  19 spaces = skipMany space
  20
  21 nonPrintableChar :: Parser Char
  22 nonPrintableChar = do c <- char '\\' >> oneOf "\\nrtf"
  23                       return $ case c of '\\' -> '\\'
  24                                          'n'  -> '\n'
  25                                          'r'  -> '\r'
  26                                          't'  -> '\t'
  27                                          'f'  -> '\f'
  28
  29 parseCharacter :: Parser LispVal
  30 parseCharacter = do char '\''
  31                     c <- noneOf ['\\', '\''] <|> try singleQuote <|> try nonPrintableChar
  32                     char '\''
  33                     return $ Character c
  34                  where
  35                     singleQuote = char '\\' >> char '\''
  36
  37 parseString :: Parser LispVal
  38 parseString = do char '"'
  39                  x <- many innerChar
  40                  char '"'
  41                  return $ String x
  42               where innerChar = noneOf ['\\', '"'] <|> try doubleQuote <|> try nonPrintableChar
  43                     doubleQuote = char '\\' >> char '"'
  44
  45 parseAtom :: Parser LispVal
  46 parseAtom = do
  47     a <- letter <|> symbol
  48     b <- many (letter <|> digit <|> symbol)
  49     let atom = a:b
  50     return $ case atom of
  51                 "#t" -> Bool True
  52                 "#f" -> Bool False
  53                 _    -> Atom atom
  54
  55 parseNumber :: Parser LispVal
  56 parseNumber = do toNum <- radix
  57                  ds <- many1 digit
  58                  let ((a,_):_) = toNum ds
  59                  return $ Number a
  60               where radix = do r <- try (char '#' >> oneOf "bodx") <|> return 'd'
  61                                return $ case r of
  62                                            'd' -> readDec
  63                                            'x' -> readHex
  64                                            'o' -> readOct
  65                                            'b' -> readInt 2 (\x -> elem x "01") (read . (:[]))
  66
  67 parseList :: Parser LispVal
  68 parseList = liftM List $ sepBy parseExpr spaces
  69
  70 parseDottedList :: Parser LispVal
  71 parseDottedList = do
  72     head <- endBy parseExpr spaces
  73     tail <- char '.' >> spaces >> parseExpr
  74     return $ DottedList head tail
  75
  76 parseQuoted :: Parser LispVal
  77 parseQuoted = do
  78     char '\''
  79     x <- parseExpr
  80     return $ List [Atom "quote", x]
  81
  82 parseExpr :: Parser LispVal
  83 parseExpr = parseString
  84         <|> parseNumber
  85         <|> parseAtom
  86         <|> try parseCharacter
  87         <|> parseQuoted
  88         <|> do char '('
  89                x <- try parseList <|> parseDottedList
  90                char ')'
  91                return x
  92
  93 readExpr :: String -> String
  94 readExpr input = case parse parseExpr "lisp" input of
  95     Left err -> "No match: " ++ show err
  96     Right val -> "Found value: " ++ showVal val
  97
  98 instance Show LispVal where show = showVal
  99 showVal :: LispVal -> String
 100 showVal (Atom atom)   = atom
 101 showVal (List list)   = "(" ++ unwordsList list ++ ")"
 102 showVal (DottedList head tail)   = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
 103 showVal (Number n)    = show n
 104 showVal (String str)  = "\"" ++ str ++ "\""
 105 showVal (Character c) = "'" ++ [c] ++ "'"
 106 showVal (Bool True)   = "#t"
 107 showVal (Bool False)  = "#f"
 108
 109 unwordsList :: [LispVal] -> String
 110 unwordsList = unwords . map showVal
 111
 112 main :: IO ()
 113 main = do
 114     args <- getLine
 115     putStrLn (readExpr args)
 116     main