Small experiment of Scheme-like parser

SCParser.hs

module SCParser where


       import Text.Parsec
       import Text.Parsec.Token
       import Text.Parsec.Language


       data Expr = ScSymbol String
                   | ScString String
                   | ScNumber Integer
                   | ScDouble Double 
                   | ScCons Expr Expr
                   | ScNil
                   | ScBool Bool
                   | ScQuote Expr
            deriving Show
       

       idSymbol = oneOf ":!$%&*+./<=>?@\\^|-~"

       schemeLanguageDef :: LanguageDef st
       schemeLanguageDef = emptyDef { 
                          commentLine = ";;"
                          , identStart = letter <|> idSymbol
                          , identLetter = alphaNum <|> idSymbol
                          , opStart = parserZero
                          , opLetter = parserZero
                        }

       schemeTokenParser = makeTokenParser schemeLanguageDef

       TokenParser {
          identifier = idParser,
          reservedOp = opParser,
          stringLiteral = stringLiteralParser,
          parens = parParser,
          lexeme = lexParser,
          naturalOrFloat = naturalOrFloatParser
       } = schemeTokenParser

       boolLiteral = lexParser (
                        do 
                          char '#'
                          val <- (char 't') <|> (char 'f')
                          return $ ScBool $ val == 't'
                    )

       quoteParser = lexParser (
                        do 
                          char '\''
                          val <- scExprParser
                          return $ ScQuote val
                    )


       atom =
          (do 
             id <- idParser
             return $ ScSymbol id)
          <|>
          (do 
             fnumber <- naturalOrFloatParser
             return $ case fnumber of
                       Left x -> ScNumber x
                       Right x -> ScDouble x)
          <|>        

          (do str <- stringLiteralParser
              return $ ScString str)
          <|>
          boolLiteral
          <|>
          quoteParser

       comp = 
          do exprs <- parParser (many scExprParser)
             return $ foldr ScCons ScNil exprs

       scExprParser =
            atom <|> comp
            

       parseIt input = parse scExprParser "" input

SCParserTests.hs

import Test.HUnit
import SCParser
import Text.Parsec

compareResult :: Either ParseError Expr -> Expr -> Bool
compareResult (Right (ScSymbol x)) (ScSymbol y) | x == y = True
compareResult _ _ = False  
  

testSymbol = TestCase 
               (assertBool "Parse simple symbol" 
                           (compareResult (parseIt "x")
                                          (ScSymbol "x")))

tests = TestList [testSymbol]

main =
     do runTestTT tests