sexp_parse.hs

import Data.Char

-- Grammar
-- =======
-- expr ->  id | num | list
-- list ->   '(' seq ')'  
-- seq -> {expr}

data Exp = EIdent String
  | EInt String
  | List [Exp]
  | Seq Exp Exp
  | NoMatch
  deriving (Show)

data Token = TIdent String
  | TInt String
  | LParen | RParen
  | Other
  | EndOfString
  deriving (Show, Eq)


segregate _ [] = ([], [])
segregate pred (x:xs)
  | pred x = let (satisfies, not_satisfies) = segregate pred xs
             in (x:satisfies, not_satisfies)
  | otherwise = ([], x:xs)


getToken :: [Char] -> (Token, [Char])
getToken [] = (EndOfString, [])
getToken (' ' : xs) = getToken xs -- skip blanks
getToken ('(' : xs) = (LParen, xs)
getToken (')' : xs) = (RParen, xs)
getToken (x : xs)
  | isAlpha x = 
    let (rest_ident, rest_string) = 
          segregate (\c -> isAlpha c || isDigit c)  xs
    in (TIdent (x:rest_ident), rest_string)
  | isDigit x = let (rest_digit, rest_string) =
                      segregate isDigit xs
                in (TInt (x:rest_digit), rest_string)
  | otherwise = (Other, xs)


-- Parser
getExpr :: [Char] -> (Exp, [Char])
getExpr cs =
  case getToken cs of
    (TIdent str, rest) -> (EIdent str, rest)
    (TInt str, rest) -> (EInt str, rest)
    (LParen, r1) -> getList cs -- let getList consume '('
    (_, rest) -> (NoMatch, rest)

getList cs =
    let (LParen, r1) = getToken cs
        (es, r2) = getSeq r1
        (RParen, r3) = getToken r2
    in (List es, r3)
                      
getSeq cs =
    case getExpr cs of
      (NoMatch, rest) -> ([], cs)
      (exp, rest) -> let (e2, r2) = getToken rest
                     in if e2 /= RParen
                        then let (exp2, r3) = getSeq rest
                             in ([exp] ++ exp2, r3)
                        else ([exp], rest)