module RlangQQ.Binary (
toRDA, fromRDA,
ToRDS(..), FromRDS(..),
FromRDA, ToRDSRecord, RDSHLIST, RDA, IxSize(..),
module Data.HList.CommonMain, ) where
import System.Process
import Unsafe.Coerce
import Control.Applicative
import qualified Data.ByteString.Lazy.UTF8 as B
import qualified Data.ByteString.UTF8 as BS (fromString, toString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as B8
import Data.Int
import Data.HList.CommonMain
import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Generic as VG
import qualified Data.Map as M
import Data.Binary
import Data.Binary.Get
import Data.Binary.Builder
import Data.Binary.Put
import qualified Data.Binary
import qualified Data.Text as T
import Data.Text.Encoding as E
import Control.Monad.Identity
#if REPA
import qualified Data.Array.Repa as R
#endif
import GHC.TypeLits
import qualified Data.Array as A
import qualified Language.Haskell.TH as TH
import qualified Codec.Compression.GZip as GZip
import HListExtras
data FLVPair = FLVPair
instance (Tagged l a ~ b) => ApplyAB FLVPair a b where
applyAB FLVPair x = Tagged x
type family UnHMapFLVPair (a :: [*]) :: [*]
type instance UnHMapFLVPair (Tagged l a ': as) = a ': UnHMapFLVPair as
type instance UnHMapFLVPair '[] = '[]
putVersion = put (262153 :: Int32)
getVersion = get :: Get Int32
class ToRDS a where
toRDS :: a -> Put
class FromRDS a where
fromRDS :: Get a
putDouble = put . (unsafeCoerce :: Double -> Int64)
getDouble = fmap (unsafeCoerce :: Int64 -> Double) get
getVectorDouble = do
14 <- get :: Get Int32
len <- get :: Get Int32
VG.replicateM (fromIntegral len) getDouble
putVectorDouble x = do
put (14 :: Int32)
put (fromIntegral $ VG.length x :: Int32)
VG.mapM_ putDouble x
getVectorInt = do
13 <- get :: Get Int32
len <- get :: Get Int32
VG.replicateM (fromIntegral len) get
putVectorInt x = do
put (13 :: Int32)
put (fromIntegral $ VG.length x :: Int32)
VG.mapM_ put x
instance ToRDS (V.Vector Double) where toRDS = putVectorDouble
instance ToRDS (VS.Vector Double) where toRDS = putVectorDouble
instance FromRDS (V.Vector Double) where fromRDS = getVectorDouble
instance FromRDS (VS.Vector Double) where fromRDS = getVectorDouble
instance ToRDS (V.Vector Int32) where toRDS = putVectorInt
instance FromRDS (V.Vector Int32) where fromRDS = getVectorInt
instance ToRDS (VS.Vector Int32) where toRDS = putVectorInt
instance FromRDS (VS.Vector Int32) where fromRDS = getVectorInt
instance ToRDS (V.Vector T.Text) where
toRDS x = do
put (16 :: Int32)
put (fromIntegral (V.length x) :: Int32)
V.mapM_ (\x -> do
putVersion
let x' = E.encodeUtf8 x
put (fromIntegral $ BS.length x' :: Int32)
putByteString x') x
instance FromRDS (V.Vector T.Text) where
fromRDS = do
16 <- get :: Get Int32
nstr <- get :: Get Int32
V.mapM (const $ do
get :: Get Int32
len <- get :: Get Int32
bs <- getByteString (fromIntegral len)
return (E.decodeUtf8 bs)
) $ V.replicate (fromIntegral nstr) ()
instance ToRDS T.Text where
toRDS x = toRDS (V.singleton x)
instance FromRDS T.Text where
fromRDS = (\(x:_) -> x) . V.toList <$> fromRDS
instance ToRDS [String] where
toRDS x = toRDS $ V.fromList (map T.pack x)
instance FromRDS [String] where
fromRDS = map T.unpack . V.toList <$> fromRDS
instance ToRDS String where
toRDS = toRDS . (:[])
instance FromRDS String where
fromRDS = fmap (\(x:_) -> x) fromRDS
data FToRDS = FToRDS
instance (ToRDS a, putm ~ Put) => ApplyAB FToRDS a putm where
applyAB FToRDS x = toRDS x
data FFromRDS = FFromRDS
instance (FromRDS b, Get b ~ getB, a ~ ()) => ApplyAB FFromRDS a getB where
applyAB FFromRDS _ = fromRDS
type RDSHLIST xs' xs = (HNat2Integral (HLength xs), HFoldr (HSeq FToRDS) Put xs Put)
instance (RDSHLIST xs' xs) => ToRDS (LST xs) where
toRDS (LST xs) = do
put (531::Int32)
let len = hNat2Integral (Proxy :: Proxy (HLength xs))
put (fromIntegral (len 2 :: Int) :: Int32)
hFoldr (HSeq FToRDS) (return () :: Put) xs :: Put
put (254::Int32)
type RDSHLIST2 b bs' l = (HSequence Get b l, HSequence ((->) ()) bs' b,
HReplicate (HLength l) FFromRDS,
HMapAux FApply (HReplicateR (HLength l) FFromRDS) bs',
SameLength (HReplicateR (HLength l) FFromRDS) bs',
SameLength bs' (HReplicateR (HLength l) FFromRDS),
HNat2Integral (HLength l))
instance (RDSHLIST2 ___ __ l) => FromRDS (LST l) where
fromRDS = withSelf $ \(self) -> do
531 <- get :: Get Int32
let len = hNat2Integral (hLength self)
len2 <- get :: Get Int32
when (len /= len2) $ error $ "fromRDS expected length: " ++ show len ++ " rds file has length: " ++ show len2
r <- hSequence (hSequence (hMap FApply $ hReplicate (hLength self) FFromRDS) ())
254 <- get :: Get Int32
return (LST r)
where
withSelf :: forall (a::[*]) m. (HList a -> m (LST a)) -> m (LST a)
withSelf x = x (error "RlangQQ.Binary.LST.self")
newtype LST (a :: [*]) = LST (HList a)
instance ToRDSRecord __ ___ xs => ToRDS (Record xs) where
toRDS (Record xs) = toRDS $ LST $
recordValues (Record xs) `hAppend`
(ListStart `HCons` (Label :: Label "names") .=. (recordLabelsString (error "recLabs" :: Proxy (RecordLabels xs))) `HCons` HNil)
type ToRDSRecord __ ___ xs = (RDSHLIST __ ___, ToRDS (LST ___),
RecordValues xs,
HList ___ ~ (HList (RecordValuesR xs) `HAppendR` HList '[ListStart, Tagged "names" [String]]),
RecordLabelsString (RecordLabels xs),
HAppend (HList (RecordValuesR xs)) (HList '[ ListStart, Tagged "names" [String]]))
type FromRDSRec a b as' as'2 bs' = (HSequence Get b as',
HSequence ((->) ()) a b,
HMapAux FLVPair as' bs',
SameLength as' bs',
SameLength bs' as',
HMapAux FApply as'2 a,
SameLength as'2 a,
SameLength a as'2,
HMapOut (HComp FShowLabel FLabelLVPair) bs' String,
RecordLabelsString (RecordLabels bs'),
HNat2Integral (HLength bs'),
HReplicate (HLength bs') FFromRDS,
HReplicateR (HLength bs')FFromRDS ~ as'2)
instance FromRDSRec a b as' as'2 bs' => FromRDS (Record bs') where
fromRDS = do
531 <- get :: Get Int32
let len = hNat2Integral (Proxy :: Proxy (HLength bs'))
len2 <- get :: Get Int32
when (len /= len2) $ error $ "fromRDS expected length: " ++ show len ++ " rds file has length: " ++ show len2
r <- hSequence
(hSequence
(hMap FApply
(hReplicate (Proxy :: Proxy (HLength bs')) FFromRDS) )
())
getListHdr
"names" <- getString
names :: [String] <- fromRDS
let names' = recordLabelsString (error "recLabs" :: Proxy (RecordLabels bs'))
unless (names == names') $ error $ "fromRDS expected names( ): " ++ show names'
++ " rds file has names attribute : " ++ show names
254 <- get :: Get Int32
return (Record (hMap FLVPair (r :: HList as') :: HList bs'))
class RecordLabelsString (a :: [Symbol]) where
recordLabelsString :: Proxy a -> [String]
instance RecordLabelsString '[] where
recordLabelsString _ = []
instance (ShowLabel x, RecordLabelsString xs)
=> RecordLabelsString (x ': xs) where
recordLabelsString _ = showLabel (Label :: Label x) : recordLabelsString (Proxy :: Proxy xs)
recLabs (Record xs) = hMapOut (HComp FShowLabel FLabelLVPair) xs
data FLabelLVPair = FLabelLVPair
instance(Tagged l a ~ x, y ~ Label l) => ApplyAB FLabelLVPair x y where
applyAB FLabelLVPair _ = (Label :: Label l)
data FShowLabel = FShowLabel
instance (string ~ String, ShowLabel l, ll ~ Label l) => ApplyAB FShowLabel ll string
where applyAB _ = showLabel
instance ToRDS [Double] where
toRDS = toRDS . V.fromList
instance FromRDS [Double] where
fromRDS = fmap V.toList $ fromRDS
instance ToRDS Double where toRDS = toRDS . (:[])
instance ToRDS Int32 where toRDS = toRDS . (:[])
instance ToRDS Integer where toRDS = toRDS . (fromIntegral :: Integer -> Int32)
instance ToRDS Int where toRDS = toRDS . (fromIntegral :: Int -> Int32)
instance FromRDS Int32 where
fromRDS = do
[x] <- fromRDS
return x
instance FromRDS Double where
fromRDS = do
[x] <- fromRDS
return x
instance FromRDS Int where
fromRDS = fromIntegral <$> (fromRDS :: Get Int32)
instance FromRDS Integer where
fromRDS = fromIntegral <$> (fromRDS :: Get Int32)
instance ToRDS [Int32] where
toRDS = toRDS . V.fromList
instance FromRDS [Int32] where
fromRDS = fmap V.toList $ fromRDS
instance ToRDS [Int] where
toRDS = toRDS . V.fromList . map (fromIntegral :: Int -> Int32)
instance FromRDS [Int] where
fromRDS = map (fromIntegral :: Int32 -> Int) . V.toList <$> fromRDS
instance ToRDS [Integer] where
toRDS = toRDS . V.fromList . map (fromIntegral :: Integer -> Int32)
instance FromRDS [Integer] where
fromRDS = map (fromIntegral :: Int32 -> Integer) . V.toList <$> fromRDS
putString s = do
let s' = BS.fromString s
put (fromIntegral $ BS.length s' :: Int32)
putByteString s'
getString = do
len <- get :: Get Int32
string <- getByteString (fromIntegral len)
return (BS.toString string)
confirmString s = do
s' <- getString
unless (s' == s) $ error $ "expected "++ s ++ ", got " ++ s'
data ListStart = ListStart
instance ToRDS ListStart where
toRDS _ = putListHdr
instance FromRDS ListStart where
fromRDS = do
getListHdr
return ListStart
putListHdr = do
put (1026 :: Int32)
put (1 :: Int32)
putVersion
getListHdr = do
[1026, 1, 262153] <- replicateM 3 (get :: Get Int32)
return ()
instance forall t l. (ToRDS t, ShowLabel l) => ToRDS (Tagged l t) where
toRDS (Tagged x) = do
putString (showLabel (undefined :: Label l))
toRDS x
instance forall t l. (FromRDS t, ShowLabel l) => FromRDS (Tagged l t) where
fromRDS = do
varName <- getString
let s = showLabel (undefined :: Label l)
unless (varName == s) $ fail $ unwords ["FromRDS: expecting label `", s , "', but got: `" , varName , "'"]
x <- fromRDS
return (Tagged x)
newtype RDA a = RDA (HList a)
instance forall rs l2 t. (ToRDS t, ToRDS (RDA rs), ShowLabel l2) => ToRDS (RDA (Tagged l2 t ': rs)) where
toRDS (RDA (x `HCons` xs)) = do
putListHdr
toRDS x
toRDS (RDA xs)
instance forall rs l2 t. (FromRDS t, FromRDS (RDA rs), ShowLabel l2) => FromRDS (RDA (Tagged l2 t ': rs)) where
fromRDS = do
getListHdr
x <- fromRDS :: Get (Tagged l2 t)
RDA xs <- fromRDS :: Get (RDA rs)
return (RDA (x `HCons` xs))
instance ToRDS (RDA '[]) where
toRDS _ = put (254::Int32)
instance FromRDS (RDA '[]) where
fromRDS = do
254 <- get :: Get Int32
return (RDA HNil)
class A.Ix i => IxSize i where
ixSize :: (i,i) -> [Int32]
fromIxSize :: [Int32] -> (i,i)
fmap concat $ forM
(map (\n -> ([| 0 |], [| fromIntegral |], n)) [''Word8, ''Word64, ''Word32, ''Word16, ''Word,
''Int, ''Int8, ''Int16, ''Int32, ''Int64, ''Integer] ++
map (\n -> ([| minBound |], [| toEnum . fromIntegral |], n)) [''Ordering, ''Char, ''Bool, ''()]) $ \ (zero, fi, name) ->
let ty = TH.conT name in
[d| instance IxSize $ty where
ixSize x = [fromIntegral (A.rangeSize x)]
fromIxSize [x] = ($zero , $fi (x1)) |]
instance (IxSize a, IxSize b) => IxSize (a,b) where
ixSize ((a,b),(a',b')) = ixSize (a,a') ++ ixSize (b,b')
fromIxSize [n1,n2] =
let (a,a') = fromIxSize [n1]
(b,b') = fromIxSize [n2]
in ((a,b),(a',b'))
instance (IxSize a, IxSize b, IxSize c) => IxSize (a,b,c) where
ixSize ((a,b,c),(a',b',c')) = ixSize (a,a') ++ ixSize (b,b') ++ ixSize (c,c')
fromIxSize [n1,n2,n3] =
let (a,a') = fromIxSize [n1]
(b,b') = fromIxSize [n2]
(c,c') = fromIxSize [n3]
in ((a,b,c),(a',b',c'))
instance (IxSize a, IxSize b, IxSize c, IxSize d) => IxSize (a,b,c,d) where
ixSize ((a,b,c,d),(a',b',c',d')) = ixSize (a,a') ++ ixSize (b,b') ++ ixSize (c,c') ++ ixSize (d,d')
fromIxSize [n1,n2,n3,n4] =
let (a,a') = fromIxSize [n1]
(b,b') = fromIxSize [n2]
(c,c') = fromIxSize [n3]
(d,d') = fromIxSize [n4]
in ((a,b,c,d),(a',b',c',d'))
instance (IxSize a, IxSize b, IxSize c, IxSize d, IxSize e) => IxSize (a,b,c,d,e) where
ixSize ((a,b,c,d,e),(a',b',c',d',e')) = ixSize (a,a') ++ ixSize (b,b') ++ ixSize (c,c') ++ ixSize (d,d') ++ ixSize (e,e')
fromIxSize [n1,n2,n3,n4,n5] =
let (a,a') = fromIxSize [n1]
(b,b') = fromIxSize [n2]
(c,c') = fromIxSize [n3]
(d,d') = fromIxSize [n4]
(e,e') = fromIxSize [n5]
in ((a,b,c,d,e),(a',b',c',d',e'))
instance (IxSize i) => ToRDS (A.Array i Double) where
toRDS arr = toRDSArray
True
(fromIntegral (A.rangeSize (A.bounds arr)))
(mapM_ putDouble (A.elems arr))
(ixSize (A.bounds arr))
toRDSArray :: Bool
-> Int32
-> Put
-> [Int32]
-> Put
toRDSArray isDouble size putElts bnds = do
put (if isDouble then 526 else 524 :: Int32)
put size
putElts
putListHdr
putString "dim"
toRDS bnds
put (254 :: Int32)
instance (IxSize i) => ToRDS (A.Array i Int32) where
toRDS arr = toRDSArray
False
(fromIntegral (A.rangeSize (A.bounds arr)))
(mapM_ put (A.elems arr))
(ixSize (A.bounds arr))
instance (IxSize i) => FromRDS (A.Array i Double) where
fromRDS = do
(526 :: Int32) <- get
(nel :: Int32) <- get
els <- replicateM (fromIntegral nel) getDouble
getListHdr
"dim" <- getString
bds <- fromRDS
(254 :: Int32) <- get
return (A.listArray (fromIxSize bds) els)
instance (IxSize i) => FromRDS (A.Array i Int32) where
fromRDS = do
(524 :: Int32) <- get
(nel :: Int32) <- get
els <- replicateM (fromIntegral nel) get
getListHdr
"dim" <- getString
bds <- fromRDS
(254 :: Int32) <- get
return (A.listArray (fromIxSize bds) els)
#if REPA
toRDSRepaArr b putFn arr =
let nel = R.size (R.extent arr) in
toRDSArray
b
(fromIntegral nel)
(forM_ [0 .. nel 1] (putFn . R.linearIndex arr))
(map fromIntegral (R.listOfShape (R.extent arr)))
instance (R.Source r Double, R.Shape sh) => ToRDS (R.Array r sh Double) where
toRDS = toRDSRepaArr True putDouble
instance (R.Source r Int32, R.Shape sh) => ToRDS (R.Array r sh Int32) where
toRDS = toRDSRepaArr False put
fromRDSRepa getElt = do
(nel :: Int32) <- get
els <- replicateM (fromIntegral nel) getElt
getListHdr
"dim" <- getString
bds :: [Int32] <- fromRDS
(254 :: Int32) <- get
return (R.fromListUnboxed (R.shapeOfList (map fromIntegral bds)) els)
instance R.Shape sh => FromRDS (R.Array R.U sh Double) where
fromRDS = do
(526 :: Int32) <- get
fromRDSRepa getDouble
instance R.Shape sh => FromRDS (R.Array R.U sh Int32) where
fromRDS = do
(524 :: Int32) <- get
fromRDSRepa get
#endif
data AnyRDS where AnyRDS :: (ToRDS a) => a -> AnyRDS
instance ToRDS AnyRDS where toRDS (AnyRDS x) = toRDS x
instance ToRDS (M.Map String AnyRDS) where
toRDS xs = do
put (531::Int32)
put (fromIntegral (M.size xs) :: Int32)
mapM_ toRDS (M.elems xs)
putListHdr
putString "names"
toRDS (M.keys xs)
put (254 :: Int32)
toRDA x = GZip.compress $ runPut $ do
mapM_ put "RDX2\nX\n"
put (2 :: Int32)
put (196609 :: Int32)
put (131840 :: Int32)
toRDS (RDA (recordValues x))
fromRDA :: forall __ r. FromRDA __ r => B.ByteString -> Record r
fromRDA x = ( $ GZip.decompress x) $ runGet $ do
let hdr = "RDX2\nX\n"
hdr' <- fmap (BS.toString) $ getByteString (BS.length (BS.fromString hdr))
unless (hdr == hdr') $ fail "wrong header"
[ _, _, _ :: Int32 ] <- replicateM 3 get
fmap (\(RDA a) -> Record (hMap FLVPair (a::HList __) )) fromRDS
type FromRDA a r = (HMapCxt FLVPair (HList a) (HList r) a r, FromRDS (RDA a))
makeLabels6 (words "x abc lab2")
sampV1 = x .=. newLVPair x [1,2,3,4 :: Double] .*.
abc .=. newLVPair abc (V.fromList [4 :: Double]) .*.
emptyRecord
testPut = B.writeFile "/tmp/foo2" $ toRDA sampV1
roundtrip = toRDA ((fromRDA $ toRDA sampV1) `asTypeOf` sampV1) == toRDA sampV1
sampleList = Record (recordValues sampV1)
testPut2 = B.writeFile "/tmp/foo3" $ toRDA (abc .=. (abc .=. sampleList) .*. emptyRecord)
sampV2 = x .=. x .=. (x .=. sampleList) .*.
abc .=. (abc .=. sampleList) .*. emptyRecord
sampV3 = x .=. newLVPair x [1,2,3,4 :: Double] .*.
abc .=. newLVPair abc "hi" .*.
lab2 .=. newLVPair lab2 sampArr .*.
emptyRecord
sampArr :: A.Array (Int,Int) Double
sampArr = A.listArray ((0,0),(2,2)) [1 .. 9]
sampMap = M.fromList [("x", AnyRDS [2 :: Double]), ("y", AnyRDS sampArr) ]
testPut3 = do
B.writeFile "/tmp/foo3" $ toRDA sampV3
readProcess "R" ["--no-save"] "load('/tmp/foo3')"
testPut4 = do
B.writeFile "/tmp/foo3" $ toRDA (x .=. (x .=. sampMap) .*. emptyRecord)
readProcess "R" ["--no-save"] "load('/tmp/foo3')"