loona.hs

loona.hs

----
---- loona.hs
----
---- Time-stamp: <2010-03-08 03:47:53 danlei>
----

module Loona
    where

import Text.ParserCombinators.Parsec
import Control.Monad
import Control.Monad.Error

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

{-
do { evaled <- return $ liftM show $ readExpr "(+ 1 1)" >>= eval; putStrLn $ extractValue $ trapError evaled }
putStrLn $ extractValue $ trapError $ liftM show $ eval $ extractValue $ readExpr "(+ 1 2)"
-}

loona expr = do
  evaled <- return $ liftM show $ readExpr expr >>= eval;
  putStrLn $ extractValue $ trapError evaled

readExpr input =
    case parse parseExpr "lisp" input of
      Left err  -> throwError (Parser err)
      Right val -> return val

parseExpr = parseAtom
        <|> parseNumber
        <|> parseString
        <|> parseQuoted
        <|> parseList

parseAtom = do first <- letter <|> alsoAllowed
               rest <- many (letter <|> digit <|> alsoAllowed)
               let atom = first:rest
               return (case atom of
                         "#t" -> Bool True
                         "#f" -> Bool False
                         _    -> Atom atom)

parseNumber = liftM (Number . read) (many1 digit)

parseString = do char '"'
                 x <- many (noneOf "\"")
                 char '"'
                 return (String x)

parseQuoted = do char '\''
                 x <- parseExpr
                 return (List [Atom "quote", x])

parseList = do char '('
               x <- liftM List (sepBy parseExpr spaces)
               return x

data LVal = Atom String
          | Number Integer
          | String String
          | Bool Bool
          | List [LVal]

instance Show LVal where
    show (Atom x)   = x
    show (Number x) = show x
    show (String x) = show x
    show (Bool x)   = case x of
                        True  -> "#t"
                        False -> "#f"
    show (List x)   = "(" ++ unwords (map show x) ++ ")"

eval :: LVal -> ThrowsError LVal
eval val@(String _)             = return val
eval val@(Number _)             = return val
eval val@(Bool _)               = return val
eval (List [Atom "quote", val]) = return val
eval (List (Atom func:args))    = mapM eval args >>= apply func
eval badForm = throwError (BadSpecialForm "Unrecognized special form" badForm)

apply func args = maybe (throwError (NoFunction "Unrecognized primitive function args" func))
                        ($ args)
                        (lookup func primitives)

primitives = [("+", numericBinop (+)),
              ("-", numericBinop (-)),
              ("*", numericBinop (*)),
              ("/", numericBinop div)]

numericBinop op singleVal@[_] = throwError (NumArgs 2 singleVal)
numericBinop op params = mapM unpack params >>= return . Number . foldl1 op
    where unpack (Number x) = return x
          unpack notNum = throwError (TypeMismatch "number" notNum)


data LError = NumArgs Integer [LVal]
            | TypeMismatch String LVal
            | Parser ParseError
            | BadSpecialForm String LVal
            | NoFunction String String
            | UnboundVar String String
            | Default String

instance Show LError where
    show (UnboundVar message varname) = message ++ ": " ++ varname
    show (BadSpecialForm message form) = message ++ ": " ++ show form
    show (NoFunction message func) = message ++ ": " ++ show func
    show (NumArgs expected found) = "Expected: " ++ show expected
    show (TypeMismatch expected found) = "Invalid type of " ++ show found ++
                                         ", expected: " ++ show expected
    show (Parser parseErr) = "Parse error at " ++ show parseErr

instance Error LError where
    noMsg = Default "An error has occurred"
    strMsg = Default

type ThrowsError = Either LError

trapError action = catchError action (return . show)
extractValue (Right val) = val