gistfile1.hs

{-# LANGUAGE RecordWildCards #-}
module Parser 
    ( LValue(..)
    , parseScheme
    , Env
    , VarMap
    ) where
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Language
import qualified Text.ParserCombinators.Parsec.Token as T
import Control.Monad
import Data.IORef
import Control.Applicative hiding ((<|>), many, optional)

schemeStyle :: LanguageDef st
schemeStyle = emptyDef
    { T.commentLine     = ";"
    , T.identStart      = letter <|> symbol
    , T.identLetter     = alphaNum <|> symbol
    , T.caseSensitive   = True
    }
    where symbol = oneOf "!$%&|*+-/:<=?>@^_~#"

T.TokenParser {..} = T.makeTokenParser schemeStyle

type VarMap = [(String, IORef LValue)]
type Env = IORef VarMap

data LValue 
    = LAtom String
    | LList [LValue]
    | LDottedList [LValue]
    | LNumber Integer
    | LString String
    | LBool Bool
    | LPrimitive ([LValue] -> LValue)
    | LFunc
      { closure :: Env
      , params  :: [String]
      , body    :: [LValue]
      }

parseString :: Parser LValue
parseString = LString <$> stringLiteral

parseAtom :: Parser LValue
parseAtom = do
    atom <- identifier
    return $ case atom of
        "#t" -> LBool True
        "#f" -> LBool False
        otherwise -> LAtom atom

parseNumber :: Parser LValue
parseNumber = LNumber <$> natural

parseList :: Parser LValue
parseList = parens $ LList <$> many1 parseExpr

parseQuoted :: Parser LValue
parseQuoted = do
    lexeme $ char '\''
    x <- parseExpr
    return $ LList [LAtom "quote", x]

parseExpr :: Parser LValue
parseExpr =
        parseAtom
    <|> parseString
    <|> parseNumber
    <|> parseQuoted
    <|> parseList


parseScheme = lexeme parseExpr