Scheme.hs

module Main where

--{
import Text.Megaparsec
import Text.Megaparsec.String
-- import Text.Megaparsec.Combinator
-- import Text.Megaparsec.Char
--}

-- import Text.ParserCombinators.Parsec hiding (spaces)
import Data.Ratio
import Data.Complex
import Data.Char (toLower)
import Control.Monad
import Numeric (readHex, readOct, readFloat)
import System.Environment

data LispVal = Atom String
             | List [LispVal]
             | DottedList [LispVal] LispVal
             | Number Integer
             | Float Double
             | Ratio Rational
             | Complex (Complex Double)
             | String String
             | Character Char
             | Bool Bool deriving Show

{-
digitChar = digit
letterChar = letter
hexDigitChar = hexDigit
octDigitChar = octDigit
alphaNumChar = alphaNum
skipSome = skipMany1
some = many1
string' = string
--}


lowerCase :: String -> String
lowerCase = map toLower

toDouble :: LispVal -> Double
toDouble(Float f) = realToFrac f
toDouble(Number n) = fromIntegral n

symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~"

spaces :: Parser ()
spaces = skipSome space

escapedChars :: Parser Char
escapedChars = do char '\\'
                  x <- anyChar
                  return $ case x of
                    '\\' -> x
                    '"' -> x
                    'n' -> '\n'
                    'r' -> '\r'
                    't' -> '\t'
                    _   -> x
  
parseString :: Parser LispVal
parseString = do
  char '"'
  x <- many $ escapedChars <|> noneOf "\"\\"
  char '"'
  return $ String x

parseCharacter :: Parser LispVal
parseCharacter = do
  try $ string "#\\"
  value <- try (string' "space" <|> string' "newline")
           <|> do { x <- anyChar; notFollowedBy alphaNumChar ; return [x] }
  return $ Character $ case (lowerCase value) of
                         "space" -> ' '
                         "newline" -> '\n'
                         otherwise -> (value !! 0)
                      
parseAtom :: Parser LispVal
parseAtom = do
  first <- letterChar <|> symbol
  rest <- many (letterChar <|> digitChar <|> symbol)
  let atom = first:rest
  return $ Atom atom

-- parseNumber :: Parser LispVal
-- parseNumber = liftM (Number . read) $ some digitChar

-- parseNumber :: Parser LispVal
-- parseNumber = do
--   num <- some digitChar
--   return $ (Number . read) num

parseFloat :: Parser LispVal
parseFloat = do x <- some digitChar
                char '.'
                y <- some digitChar
                return $ Float (float2dig (x ++ "." ++ y))
        
  
parseNumber :: Parser LispVal
parseNumber = parseDecimal1 <|> parseDecimal2 <|> parseHex <|> parseOct <|> parseBin   

parseDecimal1 :: Parser LispVal
parseDecimal1 = do some digitChar >>= (return . Number . read)

parseDecimal2 :: Parser LispVal
parseDecimal2 = do try $ string "#d"
                   x <- some digitChar
                   (return . Number . read) x

parseHex :: Parser LispVal
parseHex = do try $ string "#x"
              x <- some hexDigitChar
              return $ Number (hex2dig x)

parseOct :: Parser LispVal
parseOct = do try $ string "#o"
              x <- some octDigitChar
              return $ Number (oct2dig x)

parseBin :: Parser LispVal
parseBin = do try $ string "#b"
              x <- some (oneOf "10")
              return $ Number (bin2dig x)

hex2dig x = fst $ readHex x !! 0
oct2dig x = fst $ readOct x !! 0
float2dig x = fst $ readFloat x !! 0
bin2dig = bin2dig' 0
bin2dig' digint "" = digint
bin2dig' digint (x:xs) = let old = 2 * digint + (if x == '0' then 0 else 1) in
                           bin2dig' old xs

parseRatio :: Parser LispVal
parseRatio = do x <- some digitChar
                char '/'
                y <- some digitChar
                return $ Ratio ((read x) % (read y))

parseComplex :: Parser LispVal
parseComplex = do x <- (try parseFloat <|> parseNumber)
                  char '+'
                  y <- (try parseFloat <|> parseNumber)
                  char 'i'
                  return $ Complex (toDouble x :+ toDouble y)

parseBool :: Parser LispVal
parseBool = do char '#'
               (char 't' >> return (Bool True)) <|> (char 'f' >> return (Bool False))


parseList :: Parser LispVal
parseList = liftM List $ parseExpr `sepBy` spaces

parseDottedList :: Parser LispVal
parseDottedList = do
  head <- parseExpr `endBy` spaces
  tail <- char '.' >> spaces >> parseExpr
  return $ DottedList head tail

parseQuoted :: Parser LispVal
parseQuoted = do
  char '\''
  x <- parseExpr
  return $ List [Atom "quote", x]

parseExpr :: Parser LispVal
parseExpr = parseAtom
         <|> parseString
         <|> try parseRatio
         <|> try parseComplex
         <|> try parseFloat
         <|> parseNumber
         <|> try parseBool
         <|> parseCharacter
         <|> parseQuoted
         <|> do char '('
                x <- try parseList <|> parseDottedList
                char ')'
                return x

readExpr :: String -> String
readExpr input = case parse parseExpr "lisp" input of
  Left err -> "No match: " ++ show err
  Right val -> "Found value: " ++ (show val)

main :: IO ()
main = do
  (expr:_) <- getArgs
  putStrLn (readExpr expr)
  

when run with scheme '(a value)' goes into infinite loop