module Data.RefSerialize
( module Data.Parser
,Serialize(
showp
,readp
,rshowp
,rreadp
)
,rShow
,rRead
,insertVar
,readVar
,varName
,runR
,runW
)
where
import qualified Data.Map as M
import Data.Serialize
import Data.Parser
import Unsafe.Coerce
import Data.Char(isAlpha, isSpace, isAlphaNum)
class Serialize c where
showp :: c -> ST String
readp :: ST c
rshowp :: c -> ST String
rshowp = insertVar showp
rreadp :: ST c
rreadp = readVar readp
rShow :: Serialize c => c -> String
rShow c= runW $ rshowp c
rRead :: Serialize c => String ->c
rRead str= runR rreadp $ str
readSR :: Read a => ST a
readSR = ST(\(Stat(c,s,v)) -> let ((x,str2):_)= readsPrec 1 s in Right(Stat(c,str2,v),x) )
runR:: ST a -> String -> a
runR (ST f) str=
let (struct, vars)= readContext "where " str
in case f (Stat(M.empty,struct,vars) ) of
Right (Stat _, a) -> a
Left (Error s) -> error s
showSR :: Show a => a -> ST String
showSR var= ST(\(Stat(c,s,v)) -> Right(Stat(c,s,v),show var))
runW :: ST String -> String
runW (ST f) = case f (Stat(M.empty,"","")) of
Right (Stat (c,_,_), str) ->
let scontext= M.assocs c
show1 c= concatMap (\(n,(_,v))->"v"++ show n++"= "++v++"; ") scontext
vars= show1 c
strContext= if null vars then "" else " where {"++vars ++ "}"
in str ++ strContext
Left (Error s) -> error s
instance Serialize a => Serialize [a] where
showp []= return "[]"
showp (x:xs)= do
s1<- showp x
sn<- mapM f xs
return $ "["++ s1++ concat sn ++"]"
where
f x=do str <- showp (x:: a)
return $ ", "++str
readp = brackets $ commaSep $ readp
rshowp = insertVar rshowp1 where
rshowp1 []= insertVar return "[]"
rshowp1 (x:xs)= do
s1<- rshowp x
sn<- mapM f xs
return $ "["++ s1++ concat sn ++"]"
where
f x= do str <- rshowp (x:: a)
return $ ", "++str
rreadp = readVar $ brackets $ commaSep $ rreadp
instance (Show a, Read a) => Serialize a where
showp = showSR
readp = readSR
insertVar :: (a -> ST String) -> a -> ST String
insertVar parser x= ST(\(Stat(c,s,v))->
let mf = trytofindEntireObject x c in
case mf of
Just var -> Right(Stat(c,s,v),var)
Nothing ->
let
ST f= parser x
Right (Stat (c',_,_), str) = f (Stat(c,s,v))
in Right(Stat(addc str c',s,v), ' ':varname))
where
addc str c= M.insert ( hash) (unsafeCoerce x, str) c
hash = hasht x
varname= "v" ++ show hash
trytofindEntireObject x c=
case M.lookup hash c of
Nothing -> Nothing
Just _ -> Just varname
readVar :: Serialize c => ST c -> ST c
readVar parser= ST(\(Stat(c,s,v))->
let
s1= dropWhile isSpace s
(var, str2) = span isAlphaNum s1
in case trytofindEntireObject (numVar var) c of
Just (x,_) -> Right(Stat(c,str2,v),unsafeCoerce x)
Nothing ->
let
(_, rest)= readContext (var++"= ") v
ST f= parser
in case f (Stat(c,rest,v))
of
Right (Stat(c',s',v'),x) ->
let c''= M.insert (numVar var) (unsafeCoerce x, "") c'
in Right (Stat(c'',str2,v),x)
err -> err)
where
trytofindEntireObject x c=
case M.lookup x c of
Nothing -> Nothing
justx -> justx