{-# LANGUAGE FlexibleContexts, Rank2Types #-}
-- Standard boilerplate (de)serialization code

-- |This module provides a small number of tricky functions used to implement
-- (de)serializers.  User code should not need to import this library.
module Data.Generics.Serialization.Standard
    (ext2Q, gSerial, gDeser, (=>>), (>>$), unfoldM, match, manySat, matchs,
     getv_t, getcase, peekcase, matchws, space, readM, fromMaybeM, escape,
     unescape, mkescape, breakr) where

import Data.Generics
import Data.Char
import Control.Monad

import Data.Generics.Serialization.Streams

infixl 1 >>$, =>>

-- |Like 'ext1Q', except for a binary type constructor
ext2Q :: (Data d, Typeable2 t) =>
         (d -> q) -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
                  -> (d -> q)
ext2Q def ext = unQ (Q def `ext2` Q ext)

newtype Q q x = Q { unQ :: x -> q }

ext2 :: (Data a, Typeable2 t)
     => c a
     -> (forall a b. (Data a, Data b) => c (t a b))
     -> c a
ext2 def ext = maybe def id (dataCast2 ext)

-- |Execute two monadic actions in sequence, returning the value of the first.
-- This is mainly useful with parser combinators.
(=>>) :: Monad m => m a -> m b -> m a
(=>>) a b = do x <- a ; b ; return x

-- |Execute a monadic action, piping the result through a pure function.  This
-- is the same as flip liftM, and has the same fixity as '>>='.
(>>$) :: Monad m => m a -> (a -> b) -> m b
(>>$) = flip liftM

-- |Run a monadic action repeatedly until it returns 'Nothing'; all 'Just'
-- values are returned in a list.
unfoldM :: Monad m => m (Maybe a) -> m [a]
unfoldM a = a >>= maybe (return []) (\v -> liftM (v:) (unfoldM a))

-- |Run a monadic action over each element in an existing data object; also
-- return the 'Constr'.
gSerial :: (Data d, MonadWStream m c) =>
           (forall a . Data a => a -> m ()) -> d -> (Constr, m ())
gSerial cld v = (toConstr v, gmapQl (>>) (return ()) cld v)

-- |Build an object using monadic actions to read the 'Constr' and all children.
gDeser :: (Data d, Monad m) => (DataType -> m Constr) -> (forall a . Data a => m a) -> m d
gDeser rc cld = (\id -> do con <- rc (dataTypeOf (id undefined))
                           liftM id (fromConstrM cld con)) id

-- |Parse as many spaces as possible.
space :: MonadRStream m Char => m ()
space = do ch <- peekv
           when (maybe False isSpace ch) $ getv >> space

-- |Parse a designated character, error on a different character.
match :: MonadRStream m Char => Char -> m ()
match ch = do chr <- getv ; when (chr /= ch) (fail ("expected '" ++ (ch:'\'':[])))

-- |Parse and return one or more characters parsed using a recognition function.
manySat :: MonadRStream m a => (a -> Bool) -> m [a]
manySat pred = do x <- peekv ; if (fmap pred x /= Just True)
                               then return []
                               else liftM2 (:) getv (manySat pred)

-- |Match a string, error on discrepancy.
matchs :: MonadRStream m Char => [Char] -> m ()
matchs = mapM_ match

-- |Get one character, then run a parser (e.g. space).
getv_t :: MonadRStream m a => m b -> m a
getv_t x = getv =>> x

-- |Get one character and process it using a list of actions.
getcase :: (Eq a, MonadRStream m a) => (a -> m b) -> [(a,m b)] -> m b
getcase def lst = getv >>= \x -> maybe (def x) id (lookup x lst)

-- |Peek at one character and process it using a list of actions.
peekcase :: (Eq a, MonadRStream m a) => m b -> (a -> m b) -> [(a,m b)] -> m b
peekcase eof def lst = do x <- peekv
                          case x of Nothing -> eof
                                    Just x -> maybe (def x) id (lookup x lst)

-- |Parse a designated character, then any amount of whitespace.
matchws :: MonadRStream m Char => Char -> m ()
matchws ch = match ch >> space

-- |Parse a value using a 'Read' instance.  This differs from 'read' in that it
-- uses a general monad and type infromation for error reporting.
readM :: (Monad m, Read a, Typeable a) => String -> m a
readM s = case filter ((=="").snd) $ reads s of
            ((n,_):_) -> return n
            v         -> fail ("expected " ++ show (typeOf (fst (head v))))

-- |Convert a 'Maybe' object into any monad, using the imbedding defined by
-- fail and return.
fromMaybeM :: Monad m => String -> Maybe a -> m a
fromMaybeM st = maybe (fail st) return

-- |Escape a string.
escape :: Char -> [Char] -> [Char] -> String -> String
escape ec badch repch = concatMap (\c -> case lookup c (zip badch repch) of
                                           Nothing -> [c]
                                           Just n  -> [ec,n])

-- |Unescape a string.
unescape :: Char -> [Char] -> [Char] -> String -> Maybe String
unescape ec usech repch = un' where
    un' (x:y:xs) | x == ec = liftM2 (:) (lookup y (zip usech repch)) (un' xs)
    un' (x:xs)             = liftM (x :) (un' xs)
    un' []                 = Just []

-- |Create an escape and unescape function at the same time.  This allows
-- you to only type the translations once.
mkescape :: Char -> [Char] -> [Char] -> (String->String, String->Maybe String)
mkescape ec badch repch = (escape ec badch repch, unescape ec repch badch)

-- |Split a string at the rightmost occurence of a character matching a predicate.
breakr :: (a -> Bool) -> [a] -> ([a],[a])
breakr p lst = case break p $ reverse lst of
                 (a,(b:c)) -> (reverse c, b:reverse a)
                 (_,[]) -> (lst,[])