Another experiment of a toy-Scheme 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 x) y = compareAst x y
compareResult _ _ = False

compareAst ::  Expr -> Expr -> Bool
compareAst (ScSymbol x) (ScSymbol y) | x == y = True
compareAst (ScNumber x) (ScNumber y) | x == y = True
compareAst (ScDouble x) (ScDouble y) | x == y = True
compareAst (ScCons x1 y1) (ScCons x2 y2) 
           | (compareAst x1 x2) 
             && (compareAst y1 y2)   = True
compareAst ScNil ScNil = True
compareAst _ _ = False  
  

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



testInt = TestCase 
               (assertBool "Parse simple number" 
                           (compareResult (parseIt "1")
                                          (ScNumber 1)))

testDouble = TestCase 
               (assertBool "Parse simple double number" 
                           (compareResult (parseIt "1.1")
                                          (ScDouble 1.1)))
testSinglePar = TestCase
                 (assertBool "Parse simple parentheses expression"
                      (compareResult
                         (parseIt "(+ 1 2)")
                         $ ScCons (ScSymbol "+")
                          $ ScCons (ScNumber 1)
                           $ ScCons (ScNumber 2)
                            $ ScNil))
                                                      


tests = TestList [testSymbol,
                  testSymbolPlus,
                  testInt,
                  testDouble,
                  testSinglePar]

main =
     do runTestTT tests