RefSerialize-0.2.3: Data/RefSerialize.hs

{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances  #-}
module Data.RefSerialize 
(    --module Data.Serialize
     module Data.Parser  -- export the complete set of Parsec.Token parsers adapted for composing readp parsers
    ,Serialize(
        showp  -- :: c -> ST String  -- shows the content of a expression, must be user defined
   
       ,readp  -- ::  ST c           -- read the content of a expression, must be user defined

       ,rshowp -- :: c -> ST String  -- insert a reference (a variable in the where section) 
       --rshowp -- = insertVar  showp -- default definition
   
       ,rreadp -- :: ST c            -- read a variable in the where section (to use for deserializing rshowp output)
       --rreadp -- = readVar  readp   -- default definition
    
    
    )
    ,rShow    -- ::  Serialize c => c -> String         -- use the rshowp parser to serialize the object
    ,rRead    -- ::  Serialize c => String ->c          -- deserialize  trough the rreadp parser
    ,insertVar-- :: (a -> ST String) -> a -> ST String  -- insert a variable, its value generated by a showp parser, will be inserted in the where section
    ,readVar  -- ::  read a variable referenced int the where section
    ,varName  -- ::  two variables that point to the same address will have identical varname (derived from import System.Mem.StableName)
    ,runR     -- :: ST a -> String ->  a    runR parser string  -- deserialize the string with the parser
    ,runW     -- :: ST String -> String     runW $ parser x     -- serialize x with the parser
)   
 where
import qualified Data.Map as M
import Data.Serialize
import Data.Parser
import Unsafe.Coerce
import Data.Char(isAlpha, isSpace, isAlphaNum)
--import Token

class Serialize c where
   showp :: c -> ST String
   
   readp ::  ST c

   rshowp :: c -> ST String
   rshowp  = insertVar  showp
   
   rreadp :: ST c
   rreadp = readVar  readp 
{-
#ifdef Axioms

   serializeAxioms: Axioms c
   serializeAxioms= axioms{
         unary=   [Axiom "reverse" 
                            (\x ->  let str= rShow x
                                        y = rRead xtr
                                    in  y== x)
                                       
                   AxioM "pointer equality"
                           (\x ->   let str= rShow[x,x]
                                        [y,z] = rRead str
                                    in varName y== varName z)
                  ]
        }
#endif                                          
-}   

         
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 Serialize Int where
  showp = showSR
  readp = readSR

instance Serialize Char where
  showp = showSR
  readp = readSR
-}
instance (Show a, Read a) => Serialize a where
    showp = showSR
    readp = readSR
                
{-      
instance Serialize String where
    showp = showSR 
    readp = readSR 
    
instance Serialize Integer where
    showp = showSR
    readp = readSR                  
-}

-- | insert a variable at this position. and the expression value in the where part.
--   runW rshowp (1::Int) -> "1"
--   runW (insertVar rshowp) (1::Int) -> v1 where { v1=1}
--   This is useful when the object is referenced many times

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)) --`debug` ("s="++s++"var="++var++"rest="++rest )
            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