diff --git a/src/Data/Store/Internal.hs b/src/Data/Store/Internal.hs --- a/src/Data/Store/Internal.hs +++ b/src/Data/Store/Internal.hs @@ -91,7 +91,7 @@ import qualified Data.Text.Foreign as T import qualified Data.Text.Internal as T import qualified Data.Time as Time -import Data.Typeable.Internal (Typeable, Fingerprint) +import Data.Typeable.Internal (Typeable) import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import qualified Data.Vector.Storable as SV @@ -638,13 +638,6 @@ instance Store a => Store (Last a) instance Store a => Store (Maybe a) instance (Store a, Store b) => Store (Either a b) - --- Explicit definition needed because in base <= 4.7 (GHC 7.8), --- Fingerprint is not Typeable. -instance Store Fingerprint where - size = sizeStorableTy "GHC.Fingerprint.Type.Fingerprint" - poke = pokeStorable - peek = peekStorableTy "GHC.Fingerprint.Type.Fingerprint" -- FIXME: have TH deriving handle unboxed fields? diff --git a/src/Data/Store/TH/Internal.hs b/src/Data/Store/TH/Internal.hs --- a/src/Data/Store/TH/Internal.hs +++ b/src/Data/Store/TH/Internal.hs @@ -33,7 +33,6 @@ import Data.Store.Impl import qualified Data.Text as T import Data.Traversable (forM) -import Data.Typeable (Typeable) import qualified Data.Vector.Primitive as PV import qualified Data.Vector.Unboxed as UV import Data.Word @@ -46,7 +45,7 @@ import Safe (headMay) import TH.Derive (Deriver(..)) import TH.ReifyDataType -import TH.Utilities (freeVarsT, expectTyCon1, dequalify) +import TH.Utilities (expectTyCon1, dequalify, plainInstanceD) instance Deriver (Store a) where runDeriver _ preds ty = do @@ -256,7 +255,7 @@ #endif deriveGenericInstance :: Cxt -> Type -> Dec -deriveGenericInstance cs ty = InstanceD cs (AppT (ConT ''Store) ty) [] +deriveGenericInstance cs ty = plainInstanceD cs (AppT (ConT ''Store) ty) [] ------------------------------------------------------------------------ -- Storable @@ -269,24 +268,15 @@ stores <- postprocess . instancesMap <$> getInstances ''Store return $ M.elems $ flip M.mapMaybe (storables `M.difference` stores) $ \(TypeclassInstance cs ty _) -> - let argTy = head (tail (unAppsT ty)) in + let argTy = head (tail (unAppsT ty)) + tyNameLit = LitE (StringL (pprint ty)) in if p argTy - then Just $ makeStoreInstance (cs ++ everythingTypeable ty) - argTy - (VarE 'sizeStorable) - (VarE 'peekStorable) - (VarE 'pokeStorable) + then Just $ makeStoreInstance cs argTy + (AppE (VarE 'sizeStorableTy) tyNameLit) + (AppE (VarE 'peekStorableTy) tyNameLit) + (VarE 'pokeStorable) else Nothing --- Necessitated by the Typeable constraint on peekStorable -everythingTypeable :: Type -> Cxt -everythingTypeable = -#if MIN_VERSION_template_haskell(2,10,0) - map (AppT (ConT ''Typeable) . VarT) . freeVarsT -#else - map (ClassP ''Typeable . (:[]) . VarT) . freeVarsT -#endif - ------------------------------------------------------------------------ -- Vector @@ -345,8 +335,13 @@ filter (not . isMonoType) $ concatMap (map snd . dcFields) cons -} - let extraPreds = - map (AppT (ConT ''Store) . AppT (ConT ''UV.Vector)) $ listify isVarT ty + let extraPreds = map (storePred . AppT (ConT ''UV.Vector)) $ listify isVarT ty + storePred = +#if MIN_VERSION_template_haskell(2,10,0) + AppT (ConT ''Store) +#else + ClassP ''Store . (:[]) +#endif deriveStore (nub (preds ++ extraPreds)) ty cons _ -> fail "impossible case in deriveManyStoreUnboxVector" @@ -357,10 +352,13 @@ FamilyI _ insts <- reify ''UV.Vector return (map (everywhere (id `extT` dequalVarT) . go) insts) where - go (NewtypeInstD preds _ [ty] con _) = - (preds, ty, conToDataCons con) - go (DataInstD preds _ [ty] cons _) = - (preds, ty, concatMap conToDataCons cons) +#if MIN_VERSION_template_haskell(2,11,0) + go (NewtypeInstD preds _ [ty] _ con _) = (preds, ty, conToDataCons con) + go (DataInstD preds _ [ty] _ cons _) = (preds, ty, concatMap conToDataCons cons) +#else + go (NewtypeInstD preds _ [ty] con _) = (preds, ty, conToDataCons con) + go (DataInstD preds _ [ty] cons _) = (preds, ty, concatMap conToDataCons cons) +#endif go x = error ("Unexpected result from reifying Unboxed Vector instances: " ++ pprint x) dequalVarT (VarT n) = VarT (dequalify n) dequalVarT ty = ty @@ -379,15 +377,16 @@ makeStoreInstance :: Cxt -> Type -> Exp -> Exp -> Exp -> Dec makeStoreInstance cs ty sizeExpr peekExpr pokeExpr = - InstanceD cs - (AppT (ConT ''Store) ty) - [ ValD (VarP 'size) (NormalB sizeExpr) [] - , PragmaD (InlineP 'size Inline FunLike AllPhases) - , ValD (VarP 'peek) (NormalB peekExpr) [] - , PragmaD (InlineP 'peek Inline FunLike AllPhases) - , ValD (VarP 'poke) (NormalB pokeExpr) [] - , PragmaD (InlineP 'poke Inline FunLike AllPhases) - ] + plainInstanceD + cs + (AppT (ConT ''Store) ty) + [ ValD (VarP 'size) (NormalB sizeExpr) [] + , PragmaD (InlineP 'size Inline FunLike AllPhases) + , ValD (VarP 'peek) (NormalB peekExpr) [] + , PragmaD (InlineP 'peek Inline FunLike AllPhases) + , ValD (VarP 'poke) (NormalB pokeExpr) [] + , PragmaD (InlineP 'poke Inline FunLike AllPhases) + ] -- TODO: either generate random types that satisfy instances with -- variables in them, or have a check that there's at least a manual diff --git a/store.cabal b/store.cabal --- a/store.cabal +++ b/store.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: store -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Fast binary serialization homepage: https://github.com/fpco/store#readme bug-reports: https://github.com/fpco/store/issues @@ -68,7 +68,7 @@ , text , th-lift , th-lift-instances >= 0.1.6 - , th-utilities + , th-utilities >= 0.1.1.0 , th-reify-many , time , transformers @@ -117,7 +117,7 @@ , text , th-lift , th-lift-instances >= 0.1.6 - , th-utilities + , th-utilities >= 0.1.1.0 , th-reify-many , time , transformers @@ -166,7 +166,7 @@ , text , th-lift , th-lift-instances >= 0.1.6 - , th-utilities + , th-utilities >= 0.1.1.0 , th-reify-many , time , transformers