WIP splitting of Target module and towards parallel buildsHEADmaster

1 files changed, 75 insertions, 0 deletions

diff --git a/Coolbal/EnvBinary.hs b/Coolbal/EnvBinary.hs
new file mode 100644
index 0000000..1e3f225
--- /dev/null
+++ b/Coolbal/EnvBinary.hs
@@ -0,0 +1,75 @@
+{-# 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