{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Coolbal.EnvBinary where

import Data.Binary (get)
import Data.Binary.Get (Get, runGet)
import Data.Binary.Put (Put, runPut)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BS
import Data.Proxy
import GHC.Generics


class EnvBinary e a | a -> e where
    envget :: e -> Get a
    envput :: a -> Put

    default envget :: (Generic a, GEnvBinary e (Rep a)) => e -> Get a
    envget env = to <$> genvget env

    default envput :: (Generic a, GEnvBinary e (Rep a)) => a -> Put
    envput = genvput (Proxy @e) . from

instance EnvBinary e a => EnvBinary e [a] where
    envget env = get >>= getMany id
      where
        getMany :: ([a] -> [a]) -> Int -> Get [a]
        getMany build 0 = return (build [])
        getMany build i = do
            x <- envget env
            x `seq` getMany ((x:) . build) (i-1)

    envput = undefined

encode :: EnvBinary e a => a -> ByteString
encode = runPut . envput

decode :: EnvBinary e a => e -> ByteString -> a
decode env = runGet (envget env)

encodeFile :: EnvBinary e a => FilePath -> a -> IO ()
encodeFile f = BS.writeFile f . encode

-- TODO: This is inefficient! See the actual implementation of decodeFile in 'Data.Binary'.
decodeFile :: EnvBinary e a => e -> FilePath -> IO a
decodeFile env f = decode env <$> BS.readFile f

-- TODO: This can very well be implemented for :+: but I just haven't done that
-- yet. Perhaps to do something cool where an n-way disjunction uses only
-- log2(n) bits to encode the choice.
class GEnvBinary e r where
    genvget :: e -> Get (r x)
    genvput :: proxy e -> r x -> Put

instance GEnvBinary e c => GEnvBinary e (D1 meta c) where
    genvget e = M1 <$> genvget e
    genvput pr = genvput pr . unM1

instance GEnvBinary e s => GEnvBinary e (C1 meta s) where
    genvget e = M1 <$> genvget e
    genvput pr = genvput pr . unM1

instance GEnvBinary e f => GEnvBinary e (S1 meta f) where
    genvget e = M1 <$> genvget e
    genvput pr = genvput pr . unM1

instance EnvBinary e t => GEnvBinary e (Rec0 t) where
    genvget e = K1 <$> envget e
    genvput _ = envput . unK1