content: module Main where
  
  import Char (toLower)
  import Control.Monad (liftM)
  import Data.Array (Array (..), listArray)
  import Data.Ratio (Rational (..), (%))
  import Data.Complex (Complex (..))
  import Numeric (readOct, readHex)
  import System.Environment
  import Text.ParserCombinators.Parsec hiding (spaces)
  
  data LispVal = Atom String
               | List [LispVal]
               | DottedList [LispVal] LispVal
               | Number Integer
               | Ratio Rational
               | Float Double
               | Complex (Complex Double)
               | String String
               | Char Char
               | Bool Bool
               | Vector (Array Int LispVal)
  
  instance Show LispVal where show = showVal
  
  main :: IO ()
  main = getArgs >>= print . eval . readExpr . head
  
  readExpr :: String -> LispVal
  readExpr input = case parse parseExpr "lisp" input of
           Left err -> String $ "No match: " ++ show err
           Right val -> val
  
  -- not sure I understand the type of this function
  -- according to ghci
  repl :: IO b
  repl = getLine >>= repl' >> repl
  
  repl' :: String -> IO ()
  repl' = print . eval . readExpr
  
  --
  -- LispVal Parsers
  --
  
  parseExpr :: Parser LispVal
  parseExpr = parseAtom
            <|> parseString
            <|> try parseChar
            <|> try parseComplex
            <|> try parseFloat
            <|> try parseRatio
            <|> try parseNumber
            <|> parseBool
            <|> parseQuoted
            <|> parseQuasiquote
            <|> try parseUnquoteSplicing
            <|> parseUnquote
            <|> parseList
  
  parseAtom :: Parser LispVal
  parseAtom = do first <- letter <|> symbol
                 rest <- many (letter <|> digit <|> symbol)
                 (return . Atom) (first:rest)
  
  parseList :: Parser LispVal
  parseList = char '(' >> parseList1
  
  parseList1 :: Parser LispVal
  parseList1 = (char ')' >> (return . List) []) 
                 <|> do expr <- parseExpr
                        parseList2 [expr]
  
  parseList2 :: [LispVal] -> Parser LispVal
  parseList2 expr = (char ')' >> (return . List) (reverse expr)) 
                      <|> (spaces >> parseList3 expr)
  
  parseList3 :: [LispVal] -> Parser LispVal
  parseList3 expr = do char '.' >> spaces
                       dotted <- parseExpr
                       char ')'
                       return $ DottedList expr dotted
                    <|> do next <- parseExpr
                           parseList2 (next:expr)
  
  parseQuoted :: Parser LispVal
  parseQuoted = do char '\''
                   x <- parseExpr
                   return $ List [Atom "quote", x]
  
  parseNumber :: Parser LispVal
  parseNumber = parsePlainNumber <|> parseRadixNumber
  
  parsePlainNumber :: Parser LispVal
  parsePlainNumber = many1 digit >>= return . Number . read
  
  parseRadixNumber :: Parser LispVal
  parseRadixNumber = char '#' >> 
                     (
                          parseDecimal 
                          <|> parseBinary
                          <|> parseOctal
                          <|> parseHex
                     )
  
  parseDecimal :: Parser LispVal
  parseDecimal = do char 'd'
                    n <- many1 digit
                    (return . Number . read) n
  
  parseBinary :: Parser LispVal
  parseBinary = do char 'b'
                   n <- many $ oneOf "01"
                   (return . Number . bin2int) n
  
  parseOctal :: Parser LispVal
  parseOctal = do char 'o'
                  n <- many $ oneOf "01234567"
                  (return . Number . (readWith readOct)) n
  
  parseHex :: Parser LispVal
  parseHex = do char 'x'
                n <- many $ oneOf "0123456789abcdefABCDEF"
                (return . Number . (readWith readHex)) n
  
  parseRatio :: Parser LispVal
  parseRatio = do num <- fmap read $ many1 digit
                  char '/'
                  denom <- fmap read $ many1 digit
                  (return . Ratio) (num % denom)
  
  parseFloat :: Parser LispVal
  parseFloat = do whole <- many1 digit
                  char '.'
                  decimal <- many1 digit
                  return $ Float (read (whole++"."++decimal))
  
  parseComplex :: Parser LispVal
  parseComplex = do r <- fmap toDouble (try parseFloat <|> parsePlainNumber)
                    char '+'
                    i <- fmap toDouble (try parseFloat <|> parsePlainNumber)
                    char 'i'
                    (return . Complex) (r :+ i)
                 where toDouble (Float x) = x
                       toDouble (Number x) = fromIntegral x
  
  parseString :: Parser LispVal
  parseString = do char '"'
                   s <- many (escapedChars <|> (noneOf ['\\', '"']))
                   char '"'
                   (return . String) s
  
  parseChar :: Parser LispVal
  parseChar = do string "#\\"
                 s <- many1 letter
                 return $ case (map toLower s) of
                        "space" -> Char ' '
                        "newline" -> Char '\n'
                        [x] -> Char x
  
  parseBool :: Parser LispVal
  parseBool = do char '#'
                 c <- oneOf "tf"
                 return $ case c of
                        't' -> Bool True
                        'f' -> Bool False
  
  parseQuasiquote :: Parser LispVal
  parseQuasiquote = do char '`'
                       expr <- parseExpr
                       return $ List [Atom "quasiquote", expr]
  
  -- Bug: this allows the unquote to appear outside of a quasiquoted list
  parseUnquote :: Parser LispVal
  parseUnquote = do char ','
                    expr <- parseExpr
                    return $ List [Atom "unquote", expr]
  
  -- Bug: this allows unquote-splicing to appear outside of a quasiquoted list
  parseUnquoteSplicing :: Parser LispVal
  parseUnquoteSplicing = do string ",@"
                            expr <- parseExpr
                            return $ List [Atom "unquote-splicing", expr]
  
  parseVector :: Parser LispVal
  parseVector = do string "#("
                   elems <- sepBy parseExpr spaces
                   char ')'
                   return $ Vector (listArray (0, (length elems)-1) elems)
  
  --
  -- Show functions
  --
  
  showVal :: LispVal -> String
  showVal (String s) = "\"" ++ s ++ "\""
  showVal (Atom name) = name
  showVal (Number n) = show n
  showVal (Bool True) = "#t"
  showVal (Bool False) = "#f"
  showVal (List xs) = "(" ++ unwordsList xs ++ ")"
  showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
  
  --
  -- Evaluator
  --
  
  eval :: LispVal -> LispVal
  eval val@(String _) = val
  eval val@(Number _) = val
  eval val@(Bool _) = val
  eval (List [Atom "quote", val]) = val
  eval (List (Atom func : args)) = apply func $ map eval args
  
  --
  -- Primitive functions lookup table
  --
  primitives :: [(String, [LispVal] -> LispVal)]
  primitives = [("+", numericBinop (+))
               ,("-", numericBinop (-))
               ,("*", numericBinop (*))
               ,("/", numericBinop div)
               ,("mod", numericBinop mod)
               ,("quotient", numericBinop quot)
               ,("remainder", numericBinop rem)
               ,("not", unaryOp not')
               ,("boolean?", unaryOp boolP)
               ,("list?", unaryOp listP)
               ,("symbol?", unaryOp symbolP)
               ,("char?", unaryOp charP)
               ,("string?", unaryOp stringP)
               ,("vector?", unaryOp vectorP)
               ,("symbol->string", unaryOp symbol2string)
               ,("string->symbol", unaryOp string2symbol)]
  
  --
  -- Unary primitive defs all have type
  -- LispVal -> LispVal
  
  not' (Bool x) = (Bool . not) x
  not' _ = Bool False
  
  boolP (Bool _) = Bool True
  boolP _ = Bool False
  
  listP (List _) = Bool True
  listP (DottedList _ _) = Bool True
  listP _ = Bool False
  
  symbolP (Atom _) = Bool True
  symbolP _ = Bool False
  
  charP (Char _) = Bool True
  charP _ = Bool False
  
  stringP (String _) = Bool True
  stringP _ = Bool False
  
  vectorP (Vector _) = Bool True
  vectorP _ = Bool False
  
  symbol2string (Atom s) = String s
  symbol2string _ = error "Expecting an Atom"
  
  string2symbol (String s) = Atom s
  string2symbol _ = error "Expecting a String"
  
  
  --
  -- Primitive helpers
  --
  
  numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> LispVal
  numericBinop op params = Number $ foldl1 op $ map unpackNum params
  
  unaryOp :: (LispVal -> LispVal) -> [LispVal] -> LispVal
  unaryOp func [arg] = func arg
  
  --
  -- Helpers
  --
  
  escapedChars :: Parser Char
  escapedChars = do
               char '\\'
               c <- oneOf ['\\','"', 'n', 'r', 't']
               return $ case c of
                      '\\' -> c
                      '"'  -> c
                      'n'  -> '\n'
                      'r'  -> '\r'
                      't'  -> '\t'
  
  symbol :: Parser Char
  symbol = oneOf "!$%&|*+-/:<=>?@^_~"
  
  spaces :: Parser ()
  spaces = skipMany1 space
  bin2int :: String -> Integer
  bin2int s = sum $ map (\(i,x) -> i*(2^x)) $ zip [0..] $ map p (reverse s)
            where p '0' = 0
                  p '1' = 1
  
  readWith :: (t -> [(a, b)]) -> t -> a
  readWith f s = fst $ f s !! 0
  
  unwordsList :: [LispVal] -> String
  unwordsList = unwords . map showVal
  
  apply :: String -> [LispVal] -> LispVal
  apply func args = maybe (Bool False) ($ args) $ lookup func primitives
  
  unpackNum :: LispVal -> Integer
  unpackNum (Number n) = n
  unpackNum (List [n]) = unpackNum n
  unpackNum _ = 0