module Data.RefSerialize
(
module Data.RefSerialize.Parser
,Serialize(
showp
,readp
)
,Context
,newContext
,rshowp
,rreadp
,showps
,showpText
,readpText
,takep
,showpBinary
,readpBinary
,insertString
,insertChar
,rShow
,rRead
,insertVar
,readVar
,varName
,runR
,runRC
,runW
,readHexp
,showHexp
,getContext
)
where
import Data.RefSerialize.Serialize
import Data.RefSerialize.Parser
import Unsafe.Coerce
import Data.Char(isAlpha, isSpace, isAlphaNum)
import Numeric(readHex,showHex)
import Data.ByteString.Lazy.Char8 as B
import Debug.Trace
import Data.Binary
import System.IO.Unsafe
import qualified Data.Map as M
newContext :: IO Context
newContext = Data.RefSerialize.Serialize.empty
class Serialize c where
showp :: c -> ST ()
readp :: ST c
rshowp :: Serialize c => c -> ST ()
rshowp = insertVar showp
rreadp :: Serialize c => ST c
rreadp = readVar readp
getContext :: ST (Context, ByteString)
getContext = ST(\(Stat(c,s,v)) -> Right (Stat (c,s,v), (c,v)))
rShow :: Serialize c => c -> ByteString
rShow c= runW $ showp c
rRead :: Serialize c => ByteString -> c
rRead str= runR readp $ str
readHexp :: (Num a, Integral a) => ST a
readHexp = ST(\(Stat(c,s,v)) ->
let us= unpack s
l= readHex us
in if Prelude.null l then Left . Error $ "readHexp: not readable: " ++ us
else let ((x,str2):_)= l
in Right(Stat(c, pack $ Prelude.dropWhile isSpace str2,v),x) )
<?> "readHexp "
showHexp :: (Num a,Integral a,Show a) => a -> ST ()
showHexp var= ST(\(Stat(c,s,v)) -> Right(Stat(c, s `append` " " `append` (pack $ showHex var ""),v),())) <?> "showHexp "
showpText :: Show a => a -> ST ()
showpText var= ST(\(Stat(c,s,v)) -> Right(Stat(c, s `append` (snoc (pack $ show var) ' ') ,v),())) <?> "showp: show "
readpText :: Read a => ST a
readpText = ST(\(Stat(c,s,v)) ->
let us= unpack s
l= readsPrec 1 us
in if Prelude.null l then Left . Error $ "not readable: " ++ us
else let ((x,str2):_)= l
in Right(Stat(c, pack $ Prelude.dropWhile isSpace str2,v),x) )
<?> "readp: readsPrec "
runR:: ST a -> ByteString -> a
runR p str=unsafePerformIO $ do
c <- newContext
let (struct, vars)= readContext whereSep str
return $ runRC (c, vars) p struct
runRC :: (Context, ByteString) -> ST a -> ByteString -> a
runRC (c,vars) (ST f) struct=
case f (Stat(c,struct,vars) ) of
Right (Stat _, a) -> a
Left (Error s) -> error s
whereSep= "\r\nwhere{\r\n "
runW :: ST () -> ByteString
runW (ST f) = unsafePerformIO $ do
c <- newContext
return $ case f (Stat(c,"","")) of
Right (Stat (c,str,_), _) ->
let scontext= assocs c
vars= B.concat $ Prelude.map (\(n,(_,_,v))->"v" `append` (pack $ show n) `append` "= " `append` v `append` ";\r\n ") scontext
strContext= if Prelude.null scontext then "" else whereSep `append` vars `append` "\r\n}"
in str `append` strContext
Left (Error s) -> error s
showps :: Serialize a => a -> ST ByteString
showps x= ST(\(Stat(c,s,v))->
let
ST f= showp x
Right (Stat (c',str,_), _) = f (Stat(c,"",v))
in Right(Stat(c',s ,v), str))
insertVar :: (a -> ST ()) -> a -> ST ()
insertVar parser x= ST(\(Stat(c,s,v))->
let mf = trytofindEntireObject x c in
case mf of
Just var -> Right(Stat(c,s `append` " " `append` var,v),())
Nothing ->
let
ST f= parser x
Right (Stat (c',str,_), _) = f (Stat(c,"",v))
in Right(Stat(addc str c',s `append` (cons ' ' varname) ,v), ()))
where
addc str c= insert ( hash) (st,unsafeCoerce x, str) c
(hash,st) = hasht x
varname= pack$ "v" ++ show hash
trytofindEntireObject x c=
case Data.RefSerialize.Serialize.lookup hash c of
Nothing -> Nothing
Just _ -> Just varname
isInVars :: (a -> ST ()) -> a -> ST (Either ByteString ByteString)
isInVars parser x= ST(\(Stat(c,s,v))->
let mf = trytofindEntireObject x c in
case mf of
Just var -> Right(Stat(c,s,v),Right var)
Nothing ->
let
ST f= parser x
Right (Stat (c',str,_), _) = f (Stat(c,"",v))
in Right(Stat(addc str c',s ,v), Left varname))
where
addc str c= insert ( hash) (st,unsafeCoerce x, str) c
(hash,st) = hasht x
varname= pack$ "v" ++ show hash
trytofindEntireObject x c=
case Data.RefSerialize.Serialize.lookup hash c of
Nothing -> Nothing
Just _ -> Just varname
readVar :: Serialize c => ST c -> ST c
readVar (ST f)= ST(\(Stat(c,s,v))->
let
s1= B.dropWhile isSpace s
(var, str2) = B.span isAlphaNum s1
str3= B.dropWhile isSpace str2
nvar= numVar $ unpack var
in if B.null var then Left (Error "expected variable name" )
else
case trytofindEntireObject nvar c of
Just (_,x,_) -> Right(Stat(c,str3,v),unsafeCoerce x)
Nothing ->
let
(_, rest)= readContext (var `append` "= ") v
in if B.null rest then Left (Error ( "RedSerialize: readVar: " ++ unpack var ++ "value not found" ))
else case f (Stat(c,rest,v)) of
Right (Stat(c',s',v'),x) ->
let c''= insert nvar ( undefined, unsafeCoerce x, "") c'
in Right (Stat(c'', str3,v),x)
err -> err)
where
trytofindEntireObject x c=
case Data.RefSerialize.Serialize.lookup x c of
Nothing -> Nothing
justx -> justx
insertString :: ByteString -> ST ()
insertString s1= ST(\(Stat(c,s,v)) -> Right(Stat(c, s `append` ( snoc s1 ' '),v),()))
insertChar :: Char -> ST()
insertChar car= ST(\(Stat(c,s,v)) -> Right(Stat(c, snoc s car,v),()))
instance Serialize String where
showp = showpText
readp = readpText
instance Serialize a => Serialize [a] where
showp []= insertString "[]"
showp (x:xs)= do
insertChar '['
rshowp x
mapM f xs
insertString "]"
where
f :: Serialize a => a -> ST ()
f x= do
insertChar ','
rshowp x
readp = (brackets . commaSep $ rreadp) <?> "readp:: [] "
instance (Serialize a, Serialize b) => Serialize (a, b) where
showp (x, y)= do
insertString "("
rshowp x
insertString ","
rshowp y
insertString ")"
readp = parens (do
x <- rreadp
comma
y <- rreadp
return (x,y))
<?> "rreadp:: (,) "
instance (Serialize a, Serialize b, Serialize c) => Serialize (a, b,c) where
showp (x, y, z)= do
insertString "("
rshowp x
insertString ","
rshowp y
insertString ","
rshowp z
insertString ")"
readp = parens (do
x <- rreadp
comma
y <- rreadp
comma
z <- rreadp
return (x,y,z))
<?> "rreadp:: (,,) "
instance (Serialize a, Serialize b, Serialize c, Serialize d) => Serialize (a, b,c, d) where
showp (x, y, z, t)= do
insertString "("
rshowp x
insertString ","
rshowp y
insertString ","
rshowp z
insertString ","
rshowp t
insertString ")"
readp = parens (do
x <- rreadp
comma
y <- rreadp
comma
z <- rreadp
comma
t <- rreadp
return (x,y,z,t))
<?> "rreadp:: (,,,) "
instance (Serialize a, Ord a, Serialize b) => Serialize (M.Map a b) where
showp m= showp $ M.toList m
readp= do
list <- readp
return $ M.fromList list
instance Serialize a => Serialize (Maybe a) where
showp Nothing = insertString "Nothing"
showp (Just x) =do
insertString "Just"
showp x
readp = choice [rNothing, rJust] where
rNothing = symbol "Nothing" >> return Nothing
rJust = do
symbol "Just"
x <- readp
return $ Just x
instance (Serialize a, Serialize b) => Serialize (Either a b) where
showp (Left x) = do
insertString "Left"
rshowp x
showp (Right x) = do
insertString "Right"
rshowp x
readp = choice [rLeft, rRight] where
rLeft = symbol "Left" >> rreadp >>= \x -> return $ Left x
rRight = symbol "Right" >> rreadp >>= \x -> return $ Right x
binPrefix= "Bin "
binPrefixSp= append (pack binPrefix) " "
showpBinary :: Binary a => a -> ST ()
showpBinary x = do
let s = encode x
let n = pack . show $ B.length s
insertString $ binPrefixSp `append` n `append` " " `append` s
readpBinary :: Binary a => ST a
readpBinary = do
symbol binPrefix
n <- integer
str <- takep $ fromIntegral n
let x = decode str
return x
takep :: Int -> ST ByteString
takep n= take1 "" n
where
take1 s 0= return s
take1 s n= anyChar >>= \x -> take1 (snoc s x) (n1)
instance (Show a, Read a )=> Serialize a where
showp= showpText
readp= readpText