Sexpable.hs

{-# OPTIONS_GHC -XFlexibleInstances -XOverlappingInstances #-}
module Util.Sexpable ( Sexpable (..),ParseSexpError,PSE
                     , unexpected,unknownAtom
                     , recordToSexp,recordFromSexp)
    where

import Control.Monad.Error

import Util.Sexp (Sexp (..))

data ParseSexpError = Unexpected Sexp
                    | UnknownAtom String
                    | UnknownError String

type PSE = Either ParseSexpError

instance Show ParseSexpError where
    show (Unexpected sexp) = "Unexpected s-expression " ++ (show sexp)
    show (UnknownAtom atom) = "Unknown atom " ++ atom
    show (UnknownError msg) = "Unknown error: " ++ msg

instance Error ParseSexpError where
    noMsg = UnknownError "Unknown s-expression parsing error"
    strMsg msg = UnknownError msg

unexpected :: Sexp -> PSE a
unexpected = throwError . Unexpected

unknownAtom :: String -> PSE a
unknownAtom = throwError . UnknownAtom

class Sexpable a where
    toSexp :: a -> Sexp
    fromSexp :: Sexp -> PSE a

instance Sexpable Char where
    toSexp c = Atom [c]
    fromSexp (Atom (a:[])) = return a
    fromSexp (Atom a) = throwError $ UnknownError $ "Can not parse character from " ++ (show $ Atom a)
    fromSexp sexp = unexpected sexp

instance Sexpable [Char] where
    toSexp = Atom
    fromSexp (Atom a) = return a
    fromSexp sexp = unexpected sexp

instance (Sexpable a) => Sexpable [a] where
    toSexp = List . map toSexp
    fromSexp (List a) = forM a fromSexp
    fromSexp sexp = unexpected sexp

instance Sexpable Int where
    toSexp = Atom . show
    fromSexp (Atom a) = return $ read a
    fromSexp sexp = unexpected sexp

instance Sexpable Double where
    toSexp = Atom . show
    fromSexp (Atom a) = return $ read a
    fromSexp sexp = unexpected sexp

instance (Sexpable a) => Sexpable (Maybe a) where
    toSexp Nothing = List [Atom "optional"]
    toSexp (Just a) = List [Atom "optional",toSexp a]
    fromSexp (List [Atom "optional"]) = return Nothing
    fromSexp (List [Atom "optional",sexp]) = 
        fromSexp sexp >>= return . Just
    fromSexp sexp = unexpected sexp

instance Sexpable Bool where
    toSexp True = Atom "true"
    toSexp False = Atom "false"
    fromSexp (Atom "true") = return True
    fromSexp (Atom "false") = return False
    fromSexp sexp = unexpected sexp

recordToSexp :: [(String, b -> Sexp)] -> b -> Sexp
recordToSexp assocs record = 
    List $ (map (\(name, field) ->
                     List [Atom name, field record]
                )
           ) assocs

recordFromSexp :: (a -> Sexp -> PSE a) -> a -> Sexp -> PSE a
recordFromSexp f init (List options) = foldM f init options
recordFromSexp _ _ sexp = unexpected sexp