I have been trying out the Vinyl package, which uses type level kinds to create record structures with field level polymorphism and automatically provided lenses. Both of these features would be very handy to my project, as the former allows for record structures that are sub-types of each other without name clashes, and the latter simplifies updates on nested structures dramatically.
The problem comes with serialising the resultant structures. Normally I use Data.DeriveTH to automagically derive Binary instances, but it doesn't seem to be able to cope with these structures. The following code
{-# LANGUAGE DataKinds, TypeOperators #-}
{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
import Data.Vinyl
import Data.Binary
import Data.DeriveTH
eID = Field :: "eID" ::: Int
location = Field :: "location" ::: (Double, Double)
type Entity = Rec
[ "eID" ::: Int
, "location" ::: (Double, Double)
]
$(derive makeBinary ''Entity)
results in this error in GHCI
Exception when trying to run compile-time code:
Could not convert Dec to Decl
TySynD Main.Entity [] (AppT (ConT Data.Vinyl.Rec.Rec) (AppT (AppT PromotedConsT (AppT (AppT (ConT Data.Vinyl.Field.:::) (LitT (StrTyLit "eID"))) (ConT GHC.Types.Int))) (AppT (AppT PromotedConsT (AppT (AppT (ConT Data.Vinyl.Field.:::) (LitT (StrTyLit "location"))) (AppT (AppT (TupleT 2) (ConT GHC.Types.Double)) (ConT GHC.Types.Double)))) PromotedNilT)))
Language/Haskell/Convert.hs:(37,14)-(40,8): Non-exhaustive patterns in case
Code: derive makeBinary ''Entity
Failed, modules loaded: none.
This seems to be related to this piece of code in the Derive Convert module:
instance Convert TH.Dec HS.Decl where
conv x = case x of
DataD cxt n vs con ds -> f DataType cxt n vs con ds
NewtypeD cxt n vs con ds -> f NewType cxt n vs [con] ds
where
f t cxt n vs con ds = DataDecl sl t (c cxt) (c n) (c vs) (c con) []
Now I don't really know how to read Template Haskell so I can't make much progress here. It occurred to me that I am feeding derive a type synonym rather than a data type and that could be breaking it, so I tried wrapping it in a newtype:
newtype Entity2 = Entity2 {entity :: Entity}
$(derive makeBinary ''Entity2)
which leads to this even more obtuse error:
Exception when trying to run compile-time code:
Could not convert Type to Type
AppT (AppT PromotedConsT (AppT (AppT (ConT Data.Vinyl.Field.:::) (LitT (StrTyLit "eID"))) (ConT GHC.Types.Int))) (AppT (AppT PromotedConsT (AppT (AppT (ConT Data.Vinyl.Field.:::) (LitT (StrTyLit "location"))) (AppT (AppT (TupleT 2) (ConT GHC.Types.Double)) (ConT GHC.Types.Double)))) PromotedNilT)
Could not convert Type to Type
AppT PromotedConsT (AppT (AppT (ConT Data.Vinyl.Field.:::) (LitT (StrTyLit "eID"))) (ConT GHC.Types.Int))
Could not convert Type to Type
PromotedConsT
Language/Haskell/Convert.hs:(71,5)-(80,26): Non-exhaustive patterns in function conv
Looking in Convert.hs we have
instance Convert TH.Type HS.Type where
conv (ForallT xs cxt t) = TyForall (Just $ c xs) (c cxt) (c t)
conv (VarT x) = TyVar $ c x
conv (ConT x) | ',' `elem` show x = TyTuple Boxed []
| otherwise = TyCon $ c x
conv (AppT (AppT ArrowT x) y) = TyFun (c x) (c y)
conv (AppT ListT x) = TyList $ c x
conv (TupleT _) = TyTuple Boxed []
conv (AppT x y) = case c x of
TyTuple b xs -> TyTuple b $ xs ++ [c y]
x -> TyApp x $ c y
Now I'm guessing that what is going wrong is that GHC 7.6 has introduced new language constructs that the Derive template Haskell is not taking into account, leading to the non-exhaustive patterns.
So my question is, is there some way forward by either adding to Derive, or writing my own derivation from Vinyl record types, or something similar? It would be a shame if the benefits of Vinyl had to traded off against hand writing all the serialisation.
I expected to run into some problems with writing the Binary
instances with all the type trickery going on, but it couldn't be any easier:
instance Binary (Rec '[]) where
put RNil = return ()
get = return RNil
instance (Binary t, Binary (Rec fs)) => Binary (Rec ((sy ::: t) ': fs)) where
put ((_,x) :& xs) = put x >> put xs
get = do
x <- get
xs <- get
return ((Field, x) :& xs)