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              deriving Show
  15
  16 symbol :: Parser Char
  17 symbol = oneOf "!#$%&|*+-/:<=>?@^_~"
  18
  19 spaces :: Parser ()
  20 spaces = skipMany space
  21
  22 nonPrintableChar :: Parser Char
  23 nonPrintableChar = do c <- char '\\' >> oneOf "\\nrtf"
  24                       return $ case c of '\\' -> '\\'
  25                                          'n'  -> '\n'
  26                                          'r'  -> '\r'
  27                                          't'  -> '\t'
  28                                          'f'  -> '\f'
  29
  30 parseCharacter :: Parser LispVal
  31 parseCharacter = do char '\''
  32                     c <- noneOf ['\\', '\''] <|> try singleQuote <|> try nonPrintableChar
  33                     char '\''
  34                     return $ Character c
  35                  where
  36                     singleQuote = char '\\' >> char '\''
  37
  38 parseString :: Parser LispVal
  39 parseString = do char '"'
  40                  x <- many innerChar
  41                  char '"'
  42                  return $ String x
  43               where innerChar = noneOf ['\\', '"'] <|> try doubleQuote <|> try nonPrintableChar
  44                     doubleQuote = char '\\' >> char '"'
  45
  46 parseAtom :: Parser LispVal
  47 parseAtom = do
  48     a <- letter <|> symbol
  49     b <- many (letter <|> digit <|> symbol)
  50     let atom = a:b
  51     return $ case atom of
  52                 "#t" -> Bool True
  53                 "#f" -> Bool False
  54                 _    -> Atom atom
  55
  56 parseNumber :: Parser LispVal
  57 parseNumber = do toNum <- radix
  58                  ds <- many1 digit
  59                  let ((a,_):_) = toNum ds
  60                  return $ Number a
  61               where radix = do r <- try (char '#' >> oneOf "bodx") <|> return 'd'
  62                                return $ case r of
  63                                            'd' -> readDec
  64                                            'x' -> readHex
  65                                            'o' -> readOct
  66                                            'b' -> readInt 2 (\x -> elem x "01") (read . (:[]))
  67
  68 parseList :: Parser LispVal
  69 parseList = liftM List $ sepBy parseExpr spaces
  70
  71 parseDottedList :: Parser LispVal
  72 parseDottedList = do
  73     head <- endBy parseExpr spaces
  74     tail <- char '.' >> spaces >> parseExpr
  75     return $ DottedList head tail
  76
  77 parseQuoted :: Parser LispVal
  78 parseQuoted = do
  79     char '\''
  80     x <- parseExpr
  81     return $ List [Atom "quote", x]
  82
  83 parseExpr :: Parser LispVal
  84 parseExpr = parseString
  85         <|> parseNumber
  86         <|> parseAtom
  87         <|> try parseCharacter
  88         <|> parseQuoted
  89         <|> do char '('
  90                x <- try parseList <|> parseDottedList
  91                char ')'
  92                return x
  93
  94 readExpr :: String -> String
  95 readExpr input = case parse parseExpr "lisp" input of
  96     Left err -> "No match: " ++ show err
  97     Right val -> "Found value: " ++ showVal val
  98
  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