{-# 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,[])