@@ -10,13 +10,11 @@
1010--
1111module Streamly.Internal.Data.Unbox.TH
1212 ( deriveUnbox
13− , deriveUnboxWith
1413
1514 -- th-helpers
1615 , DataCon(..)
1716 , DataType(..)
1817 , reifyDataType
19− , appsT
2018 ) where
2119
2220--------------------------------------------------------------------------------
@@ -69,10 +67,6 @@ tvName = elimTV id (\n _ -> n)
6967tyVarBndrName :: TyVarBndr_ flag -> Name
7068tyVarBndrName = tvName
7169
72−appsT :: Type -> [Type] -> Type
73−appsT x [] = x
74−appsT x (y:xs) = appsT (AppT x y) xs
75−
7670-- | Simplified info about a 'DataD'. Omits deriving, strictness,
7771-- kind info, and whether it's @data@ or @newtype@.
7872data DataType = DataType
@@ -397,8 +391,8 @@ mkPokeExpr headTy cons =
397391-- [(Nothing, (ConT ''Bool)), (Nothing, (VarT (mkName "b")))]
398392-- ])
399393-- @
400−deriveUnboxInternal :: Cxt -> Type -> [DataCon] -> Q [Dec]
401−deriveUnboxInternal preds headTy cons = do
394+deriveUnboxInternal :: Type -> [DataCon] -> ([Dec] -> Q [Dec]) -> Q [Dec]
395+deriveUnboxInternal headTy cons mkDec = do
402396 sizeOfMethod <- mkSizeOfExpr headTy cons
403397 peekMethod <- mkPeekExpr headTy cons
404398 pokeMethod <- mkPokeExpr headTy cons
@@ -428,77 +422,54 @@ deriveUnboxInternal preds headTy cons = do
428422 []
429423 ]
430424 ]
431− return [InstanceD Nothing preds (AppT (ConT ''Unbox) headTy) methods]
425+ mkDec methods
432426
433−-- | @deriveUnbox dataTypeName@ generates a template Haskell splice consisting
434−-- of a declaration of the 'Unbox' instance for the given dataTypeName, all type
435−-- parameters of dataTypeName are required to have the 'Unbox' constraint.
436−--
437−-- For example,
438−--
439−-- @
440−-- data CustomDataType a b c = ...
441−-- \$(deriveUnbox ''CustomDataType)
442−-- @
427+-- | Given an 'Unbox' instance declaration splice without the methods,
428+-- generate a full instance declaration including all the type class methods.
443429--
444−-- Generates the following code:
430+-- Usage:
445431--
446432-- @
447−-- instance (Unbox a, Unbox b, Unbox c) => Unbox (CustomDataType a b c) where
448−-- ...
433+-- \$(deriveUnbox [d|instance Unbox a => Unbox (Maybe a)|])
449434-- @
450−--
451−-- To control which type parameters get the Unbox constraint, use
452−-- 'deriveUnboxWith'.
453−deriveUnbox :: Name -> Q [Dec]
454−deriveUnbox name = do
455− dt <- reifyDataType name
456− let preds = map (unboxPred . VarT) (dtTvs dt)
457− headTy = appsT (ConT name) (map VarT (dtTvs dt))
458− cons = dtCons dt
459− deriveUnboxInternal preds headTy cons
435+deriveUnbox :: Q [Dec] -> Q [Dec]
436+deriveUnbox mDecs = do
437+ dec <- mDecs
438+ case dec of
439+ [InstanceD mo preds headTyWC []] -> do
440+ let headTy = unwrap dec headTyWC
441+ dt <- reifyDataType (getMainTypeName dec headTy)
442+ let cons = dtCons dt
443+ deriveUnboxInternal headTy cons (mkInst mo preds headTyWC)
444+ _ -> errorMessage dec
460445
461446 where
462447
463− unboxPred ty =
464−#if MIN_VERSION_template_haskell(2,10,0)
465− AppT (ConT ''Unbox) ty
466−#else
467− ClassP ''Unbox [ty]
468−#endif
448+ mkInst mo preds headTyWC methods =
449+ pure [InstanceD mo preds headTyWC methods]
450+
451+ errorMessage dec =
452+ error $ unlines
453+ [ "Error: deriveUnbox:"
454+ , ""
455+ , ">> " ++ pprint dec
456+ , ""
457+ , "The supplied declaration not a valid instance declaration."
458+ , "Provide a valid Haskell instance declaration without a body."
459+ , ""
460+ , "Examples:"
461+ , "instance Unbox (Proxy a)"
462+ , "instance Unbox a => Unbox (Identity a)"
463+ , "instance Unbox (TableT Identity)"
464+ ]
469465
470−-- | @deriveUnbox dataTypeName@ generates a template Haskell splice consisting
471−-- of a declaration of the 'Unbox' instance for the given dataTypeName,
472−-- varNames is a list of parameter names of dataTypeName that are required
473−-- to have the 'Unbox' constraint.
474−--
475−-- For example,
476−--
477−-- @
478−-- data CustomDataType a b c = ...
479−-- \$(deriveUnboxWith ["a", "c"] ''CustomDataType)
480−-- @
481−--
482−-- Generates the following code:
483−--
484−-- @
485−-- instance (Unbox a, Unbox c) => Unbox (CustomDataType a b c) where
486−-- ...
487−-- @
488−--
489−deriveUnboxWith :: [String] -> Name -> Q [Dec]
490−deriveUnboxWith vars name = do
491− dt <- reifyDataType name
492− let preds = map (unboxPred . VarT) (fmap mkName vars)
493− headTy = appsT (ConT name) (map VarT (dtTvs dt))
494− cons = dtCons dt
495− deriveUnboxInternal preds headTy cons
466+ unwrap _ (AppT (ConT _) r) = r
467+ unwrap dec _ = errorMessage dec
496468
497− where
469+ getMainTypeName dec = go
498470
499− unboxPred ty =
500−#if MIN_VERSION_template_haskell(2,10,0)
501− AppT (ConT ''Unbox) ty
502−#else
503− ClassP ''Unbox [ty]
504−#endif
471+ where
472+
473+ go (ConT nm) = nm
474+ go (AppT l _) = go l
475+ go _ = errorMessage dec