{-# LANGUAGE FlexibleContexts #-}
{- | This module implements serialization to\/from a subset of R5RS s-expressions.
   Several limitations currently exist:

* Vectors are not recognized or generated.

* (Quasi)quote notation is not supported.

* Constructor names are parsed case-sensitively.
-}

module Data.Generics.Serialization.SExp
    (sexpSerialize, sexpDeserialize) where

import Data.Generics.Serialization.Standard
import Data.Generics.Serialization.Streams
import Data.Generics.Aliases
import Data.Generics.Basics
import Data.List
import Data.Char
import Control.Monad ; import Data.Maybe
import Data.Ratio ; import Data.Complex

-- |Serialize an arbitrary value to an s-expression.
sexpSerialize :: (Data a, MonadWStream m Char) => a -> m ()
sexpSerialize = serGeneral `ext1Q` serList `extQ` serInt `extQ` serString
                `extQ` serBool `extQ` serChar `extQ` serInteger `extQ`
                serFloat `extQ` serDouble `extQ` serRational `extQ` serComplexD
                `extQ` serComplexF

esca :: String -> String
unesca :: String -> Maybe String
(esca, unesca) = mkescape '~' "\\()|\"+-." "blrpqamd"

serGeneral :: (Data a, MonadWStream m Char) => a -> m ()
serGeneral a = let (cn, act) = gSerial ((putv " " >>) . sexpSerialize) a in
               putv "(" >> putv (esca $ show cn) >> act >> putv ")"

replExp :: Char -> String -> String
replExp n str | elem 'e' str = map (\x -> if x == 'e' then n else x) str
              | otherwise    = str ++ (n:'0':[])

serInt :: (MonadWStream m Char) => Int -> m ()
serInt n     = putv (show (n :: Int))

serInteger :: (MonadWStream m Char) => Integer -> m ()
serInteger n = putv (show (n :: Integer))

serFloat :: (MonadWStream m Char) => Float -> m ()
serFloat n   = putv (replExp 'f' $ show (n :: Float))

serDouble :: (MonadWStream m Char) => Double -> m ()
serDouble n  = putv (replExp 'd' $ show (n :: Double))

serRational :: (MonadWStream m Char) => Ratio Integer -> m ()
serRational a = putv (show (numerator a) ++ "/" ++ show (denominator a :: Integer))

serComplexF :: (MonadWStream m Char) => Complex Float -> m ()
serComplexF (a :+ b) = putv (replExp 'f' (show (a :: Float)) ++ "+" ++ replExp 'f' (show (b :: Float)) ++ "i")

serComplexD :: (MonadWStream m Char) => Complex Double -> m ()
serComplexD (a :+ b) = putv (replExp 'd' (show (a :: Double)) ++ "+" ++ replExp 'd' (show (b :: Double)) ++ "i")

serString :: (MonadWStream m Char) => String -> m ()
serString str = putv "\"" >> putv (escape '\\' "\\\"" "\\\"" str) >> putv "\""

serChar :: (MonadWStream m Char) => Char -> m ()
serChar ch = putv ('#':'\\':ch:[])

serBool :: (MonadWStream m Char) => Bool -> m ()
serBool tr = putv (if tr then "#t" else "#f")

serList :: (Data a, MonadWStream m Char) => [a] -> m ()
serList ls = putv "(" >> sequence_ (intersperse (putv " ") (map sexpSerialize ls)) >> putv ")"

-- |Deserialize an arbitrary value from an s-expression.
sexpDeserialize :: (Data a, MonadRStream m Char) => m a
sexpDeserialize = genDeser `extR` desBool `extR` desInt `ext1R` desList
                  `extR` desChar `extR` desString `extR` desInteger `extR`
                  desDouble `extR` desFloat `extR` desCDouble `extR` desCFloat
                  `extR` desRational

genDeser :: (Data d, MonadRStream m Char) => m d
genDeser = matchws '(' >> gDeser readCon sexpDeserialize =>> matchws ')'

ws :: MonadRStream m Char => m ()
ws = do k <- peekv ; when (k == Just ';') skcom
    where skcom = do k <- getv ; if (k == '\n') then ws else skcom

atom :: MonadRStream m Char => m String
atom = (manySat (\x -> not $ isSpace x || elem x "();\"") =>> ws) >>$
       unesca >>= fromMaybeM "invalid escape"

data SNumber = SCD (Complex Double) | SCF (Complex Float) | SI Integer
             | SR Rational | SD Double | SF Float deriving(Show)
snumber :: String -> Maybe SNumber
snumber str = num (map toLower str) 10 Nothing
    where
      num ('#':'b':xs) _ exact = num xs 2 exact
      num ('#':'o':xs) _ exact = num xs 8 exact
      num ('#':'d':xs) _ exact = num xs 10 exact
      num ('#':'x':xs) _ exact = num xs 16 exact
      num ('#':'i':xs) base _ = num xs base (Just False)
      num ('#':'e':xs) base _ = num xs base (Just True)
      num xs base exact = complex xs base exact

      complex str base exact
          | elem '@' str    = let (a,('_':b)) = break (=='@') str
                              in join $ liftM2 mkpolar (real a base exact)
                                                       (real b base exact)
          | str == ""       = Nothing
          | last str == 'i' = let (a,b) = breakr (`elem` "+-") (init str)
                                  bn = case b of "+" -> Just $ SI 1 ; "-" -> Just $ SI (-1)
                                                 x -> real x base exact
                                  an = case a of "" -> Just $ SI 0
                                                 x -> real x base exact
                              in join (liftM2 mkrect an bn)
          | otherwise       = real str base exact

      real ('+':str) base exact = ureal str base exact
      real ('-':str) base exact = liftM negatesn (ureal str base exact)
      real str base exact       = ureal str base exact

      ureal str base exact
          | base == 10 && intersect str "es.fdl" /= "" = decimal str exact
          | elem '/' str                         = let (a,(_:b)) = breakr (=='/') str in
                                                   join $ liftM2 mkrat (integer a base exact) (integer b base exact)
          | otherwise                            = integer str base exact

      integer "" _ _ = Nothing
      integer str base exact = let i = foldl1 (\a b -> a * base + b) `fmap` mapM fromDigit str in
                               if fromMaybe True exact then liftM SI i else liftM (SD . fromInteger) i
          where fromDigit ch = do d <- dig' ch ; guard (d < base) ; return d
                dig' ch | ch >= '0' && ch <= '9' = Just (toInteger $ fromEnum ch - fromEnum '0')
                        | ch >= 'a' && ch <= 'f' = Just (toInteger $ 10 + fromEnum ch - fromEnum 'a')
                        | otherwise              = Nothing

      sinteger ('+':str) = integer str 10 Nothing
      sinteger ('-':str) = liftM negatesn (integer str 10 Nothing)
      sinteger str = integer str 10 Nothing
      decimal str exact =
          let (nm,suf) = break (`elem` "defls") str
              num = baredecimal nm exact
              ~(_:sexp) = suf
              exp = sinteger sexp
          in case suf of [] -> num
                         (k:_) -> let enum = liftM2 mkexp exp num in
                                  if (elem k "sf") then liftM floatize enum else enum

      baredecimal str exact = let (l,r) = break (=='.') str
                                  ipart = case l of "" -> Just $ SI 0 ; _ -> integer l 10 Nothing
                                  (fpart,fl) = case r of "." -> (Just $ SI 0,0) ; "" -> (Just $ SI 0,0)
                                                         ('.':x) -> (integer x 10 Nothing,length x)
                              in if (fromMaybe False exact)
                                    then liftM2 (mkratp fl) ipart fpart
                                    else liftM2 (mkfltp fl) ipart fpart


      mkfltp pow (SI ip) (SI fp) = SD $ fromInteger ip + fromInteger fp * 10 ** (- fromInteger (toInteger pow))
      mkratp pow (SI ip) (SI fp) = SR $ fromInteger ip + fromInteger fp * 10 ^^ (-pow)
      floatize (SD x) = SF (fromRational $ toRational x)
      floatize x = x
      mkrat (SI _) (SI 0) = Nothing
      mkrat (SI n) (SI d) = Just $ SR $ fromInteger n / fromInteger d
      mkrat (SD n) (SD d) = Just $ SD (n/d)
      mkexp (SI exp) (SR val) = SR $ val * 10 ^^ exp
      mkexp (SI exp) (SD val) = SD $ val * 10 ^^ exp
      mkrect (SD v1) (SD v2) = Just $ SCD $ v1 :+ v2
      mkrect (SF v1) (SF v2) = Just $ SCF $ v1 :+ v2
      mkrect _ _ = Nothing
      mkpolar (SD v1) (SD v2) = Just $ SCD $ mkPolar v1 v2
      mkpolar (SF v1) (SF v2) = Just $ SCF $ mkPolar v1 v2
      mkpolar _ _ = Nothing
      negatesn (SD v) = SD $ negate v
      negatesn (SF v) = SF $ negate v
      negatesn (SCF v) = SCF $ negate v
      negatesn (SCD v) = SCD $ negate v
      negatesn (SR v) = SR $ negate v
      negatesn (SI v) = SI $ negate v

readCon :: MonadRStream m Char => DataType -> m Constr
readCon dt = do atom >>$ readConstr dt >>= fromMaybeM "no such constructor"

desBool :: MonadRStream m Char => m Bool
desBool = do ch <- (match '#' >> getv =>> ws)
             case ch of 't' -> return True
                        'f' -> return False
                        _   -> fail "expected boolean"

desNumber :: MonadRStream m Char => m SNumber
desNumber = atom >>$ snumber >>= fromMaybeM "invalid number"

desChar :: MonadRStream m Char => m Char
desChar = matchs "#\\" >> getv_t ws

desInt :: MonadRStream m Char => m Int
desInt = desNumber >>= \num -> case num of SI i | toInteger (fromInteger i :: Int) == i -> return (fromInteger i)
                                           _ -> fail "invalid int"

desInteger :: MonadRStream m Char => m Integer
desInteger = desNumber >>= \num -> case num of SI i -> return i
                                               _ -> fail "invalid integer"

desFloat :: MonadRStream m Char => m Float
desFloat = desNumber >>= \num -> case num of SF f -> return f
                                             _ -> fail "invalid float"

desDouble :: MonadRStream m Char => m Double
desDouble = desNumber >>= \num -> case num of SD f -> return f
                                              _ -> fail "invalid double"

desCFloat :: MonadRStream m Char => m (Complex Float)
desCFloat = desNumber >>= \num -> case num of SCF f -> return f
                                              SF f -> return (f :+ 0)
                                              _ -> fail "invalid complex float"

desCDouble :: MonadRStream m Char => m (Complex Double)
desCDouble = desNumber >>= \num -> case num of SCD f -> return f
                                               SD f -> return (f :+ 0)
                                               _ -> fail "invalid complex double"

desRational :: MonadRStream m Char => m Rational
desRational = desNumber >>= \num -> case num of SR r -> return r
                                                SI i -> return (fromInteger i)
                                                _ -> fail "invalid rational"

desList :: (Data a, MonadRStream m Char) => m [a]
desList = match '(' >> ws >> unfoldM des' =>> match ')' =>> ws where
    des' = peekv >>= \ch -> if (ch == Just ')') then return Nothing
                            else Just `liftM` sexpDeserialize

desString :: MonadRStream m Char => m String
desString = match '"' >> unfoldM strch =>> ws
    where strch :: MonadRStream m Char => m (Maybe Char)
          strch = getcase (return . Just) [('"', return Nothing),
                                           ('\\', liftM Just getv)]