Sexp.hs

module Util.Sexp ( Sexp (..),ValidSexp (..),parse,parseFile,prettyPrint
                 , validate)
    where

import Control.Applicative ((<$>))
import Text.ParserCombinators.Parsec ((<|>),(<?>),Parser)
import qualified Text.ParserCombinators.Parsec as P
import qualified Text.ParserCombinators.Parsec.Language as L
import qualified Text.ParserCombinators.Parsec.Token as T

data Sexp = Atom String
          | List [Sexp]

instance Show Sexp where
    show (Atom a) = show a
    show (List a) = "(" ++ (unwords $ map show a) ++ ")"

data ValidSexp = ValidAtom
               | ValidList [ValidSexp]
               | ValidListOf ValidSexp
               | ValidSexp

parse :: String -> Either String Sexp
parse = either (Left . show) Right . P.parse sexp ""

parseFile :: FilePath -> IO (Either String Sexp)
parseFile filePath = parse <$> readFile filePath

sexp,simpleSexp,atom,list :: Parser Sexp

sexp = do { T.whiteSpace lexer
          ; e <- simpleSexp
          ; P.eof
          ; return e
          } <?> "s-expression"

simpleSexp = atom <|> list <?> "simple s-expression"

atom = (Atom <$> string) <|> (Atom <$> identifier) <?> "atom"

list = List <$> (P.between (symbol "(") (symbol ")") 
                      $ P.many simpleSexp) <?> "list"

symbol = T.symbol lexer
string = T.stringLiteral lexer
identifier = T.identifier lexer

lexer :: T.TokenParser ()
lexer = T.makeTokenParser $ L.emptyDef 

prettyPrint :: Sexp -> String
prettyPrint =
    let isAtomList (List l) = 
            let isAtom (Atom _) = True
                isAtom _ = False
            in
              and $ map isAtom l
        isAtomList _ = False

        ppList space (List l) =
            let lines = map (pp $ "  " ++ space) l
            in
              unlines ([space ++ "("] ++ lines) ++ space ++ ")"

        pp space sexp = 
            if isAtomList sexp 
            then space ++ (show sexp)
            else case sexp of
                   List _ -> ppList space sexp
                   Atom a -> space ++ (show a)
    in
      pp ""

validate :: ValidSexp -> Sexp -> Bool
validate valid sexp =
    case (valid,sexp) of
      (ValidAtom,Atom _) -> True
      (ValidList v,List l) -> 
          if length v /= length l then False
          else and $ map (uncurry validate) $ zip v l
      (ValidListOf v,List l) -> and $ map (validate v) l
      (ValidSexp,_) -> True
      _ -> False