{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -XIncoherentInstances #-}

-----------------------------------------------------------------------------
--
-- Module      :  Data.RefSerialize
-- Copyright   :  Alberto Gómez Corona
-- License     :  see LICENSE
--
-- Maintainer  :  agocorona@gmail.com
-- Stability   :  experimental


-- |   Read, Show and Data.Binary do not check for repeated references to the same address.
--     As a result, the data is duplicated when seri<alized. This is a waste of space in the filesystem
--     and  also a waste of serialization time. but the worst consequence is that, when the serialized data is read,
--     it allocates multiple copies for the same object when referenced multiple times. Because multiple referenced
--     data is very typical in a pure language such is Haskell, this means that the resulting data loose the beatiful
--     economy of space and processing time that referential transparency permits.
--
--     Here comes a brief tutorial:
--
--     @runW applies showp, the serialization parser of the instance Int for the RefSerialize class
--
--    Data.RefSerialize>let x= 5 :: Int
--    Data.RefSerialize>runW $ showp x
--    "5"
--
--    every instance of Read and Show is an instance of RefSerialize. for how to construct showp and readp parsers, see the demo.hs
--
--    rshowp is derived from showp, it labels the serialized data with a variable name
--
--    Data.RefSerialize>runW $ rshowp x
--    " v8 where {v8= 5; }"
--
--    Data.RefSerialize>runW $ rshowp [2::Int,3::Int]
--    " v6 where {v6= [ v9,  v10]; v9= 2; v10= 3; }"
--
--    while showp does a normal show serialization
--
--    Data.RefSerialize>runW $ showp [x,x]
--    "[5, 5]"
--
--    rshowp variables are serialized memory references: no piece of data that point to the same addrees is serialized but one time
--
--    Data.RefSerialize>runW $ rshowp [x,x]
--    " v9 where {v6= 5; v9= [ v6, v6]; }"
--
--
--
--    "this happens recursively"
--
--    Data.RefSerialize>let xs= [x,x] in str = runW $ rshowp [xs,xs]
--    Data.RefSerialize>str
--    " v8 where {v8= [ v10, v10]; v9= 5; v10= [ v9, v9]; }"
--
--    the rshowp serialized data is read with rreadp. The showp serialized data is read by readp
--
--    Data.RefSerialize>let xss= runR rreadp str :: [[Int]]
--    Data.RefSerialize>print xss
--    [[5,5],[5,5]]
--
--    this is the deserialized data
--
--    the deserialized data keep the references!! pointers are restored! That is the whole point!
--
--    Data.RefSerialize>varName xss !! 0 == varName xss !! 1
--    True
--
--
--    rShow= runW rshowp
--    rRead= runR rreadp
--
--    Data.RefSerialize>rShow x
--    " v11 where {v11= 5; }"
--
--
--    In the definition of a referencing parser non referencing parsers can be used and viceversa. Use a referencing parser
--    when the piece of data is being referenced many times inside the serialized data.
--
--    by default the referencing parser is constructed by:
--
--
--    rshowp= insertVar showp
--    rreadp= readVar readp
--    but this can be redefined. See for example the instance of [] in RefSerialize.hs
--
--    This is an example of a showp parser for a simple data structure.
--
--    data S= S Int Int deriving ( Show, Eq)
--
--    instance  Serialize S  where
--        showp (S x y)= do
--                        xs <- rshowp x  -- rshowp parsers can be inside showp parser
--                        ys <- rshowp y
--                        return $ "S "++xs++" "++ys
--
--
--
--       readp =  do
--                        symbol "S"     -- I included a (almost) complete Parsec for deserialization
--                        x <- rreadp
--                        y <- rreadp
--                        return $ S x y
--
--    there is a mix between referencing and no referencing parser here:
--
--    Data.RefSerialize>putStrLn $ runW $ showp $ S x x
--    S  v23 v23 where {v23= 5; }@







module Data.RefSerialize
(
     module Data.Parser
    ,Serialize(
        showp

       ,readp

       ,rshowp

       ,rreadp

    )
    ,rShow
    ,rRead
    ,insertVar
    ,readVar
    ,varName
    ,runR
    ,runW
    ,readHexp
    ,showHexp
)

 where
import qualified Data.Map as M
import Data.Serialize
import Data.Parser
import Unsafe.Coerce
import Data.Char(isAlpha, isSpace, isAlphaNum)
import Numeric(readHex,showHex)


class Serialize c where

   showp :: c -> ST String     -- ^   shows the content of a expression, must be  defined bu the user

   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

   rshowp  = insertVar  showp

   rreadp :: ST c                     --  ^ read a variable in the where section (to use for deserializing rshowp output).   @rreadp  = readVar  readp@   -- default definition
   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
-}
-- | use the rshowp parser to serialize the object
-- @ rShow c= runW  $  rshowp c@
rShow :: Serialize c => c -> String
rShow c= runW  $  rshowp c

-- | deserialize  trough the rreadp parser
-- @ rRead str= runR rreadp $ str@
rRead :: Serialize c => String -> c
rRead str= runR rreadp $ str

readHexp :: (Num a, Integral a) => ST a
readHexp = ST(\(Stat(c,s,v)) ->
               let l=  readHex  s
               in if null l then Left . Error $  "not readable: " ++ s
                             else let ((x,str2):_)= l
                                        in Right(Stat(c,dropWhile isSpace str2,v),x) )
                <?> "readHexp "

readSR :: Read a => ST a

readSR = ST(\(Stat(c,s,v)) ->
               let l=  readsPrec 1 s
               in if null l then Left . Error $  "not readable: " ++ s
                             else let ((x,str2):_)= l
                                        in Right(Stat(c,dropWhile isSpace str2,v),x) )
                <?> "readp: readsPrec "


--readSR = ST(\(Stat(c,s,v)) -> let ((x,str2):_)= readsPrec 1 s in Right(Stat(c,str2,v),x) )


-- |  deserialize the string with the parser
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

showHexp :: (Num a,Integral a) => a -> ST String
showHexp var= ST(\(Stat(c,s,v)) ->  Right(Stat(c,s,v),showHex var ""))  <?> "showHexp "

showSR :: Show a => a -> ST String
showSR var= ST(\(Stat(c,s,v)) ->  Right(Stat(c,s,v),show var))   <?> "showp: show "


-- |   serialize x with the parser
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

-- -------------Instances

instance Serialize String where
    showp = showSR
    readp = readSR

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)    <?> "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)   <?> "rreadp:: [] "


instance (Show a, Read a) => Serialize a where
    showp = showSR
    readp = readSR



-- | insert a variable at this position. The expression value is inserted the where part if it is not already
-- created. If the address of this object being parsed correspond with an address already parsed and
-- it is in the where section, then the same variable name is used
--   @runW showp (1::Int)                                -> "1"
--   runW (insertVar showp) (1::Int)                ->  v1 where { v1=1}
--   runW (insertVar showp) [(1::Int) ,1]        -> [v1.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


-- | deserialize a variable serialized with insertVar. Memory references are restored
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