git.iko.soy/streamly
on master help sign in
Make the proper variable mapping for Unbox
fdc1733Adithya Kumar
core/src/Streamly/Internal/Data/Unbox/TH.hs+25−6
compare with master
unifiedsplit
@@ -23,6 +23,7 @@ module Streamly.Internal.Data.Unbox.TH
23
23
24import Data.Word (Word16, Word32, Word64, Word8)
24import Data.Word (Word16, Word32, Word64, Word8)
25import Data.Proxy (Proxy(..))
25import Data.Proxy (Proxy(..))
26+import Data.List (elemIndex)
26
27
27import Language.Haskell.TH
28import Language.Haskell.TH
28import Language.Haskell.TH.Syntax
29import Language.Haskell.TH.Syntax
@@ -438,13 +439,31 @@ deriveUnbox mDecs = do
438 case dec of
439 case dec of
439 [InstanceD mo preds headTyWC []] -> do
440 [InstanceD mo preds headTyWC []] -> do
440 let headTy = unwrap dec headTyWC
441 let headTy = unwrap dec headTyWC
441− dt <- reifyDataType (getMainTypeName dec headTy)
442+ (mainTyName, subs) = getMainTypeName dec headTy
443+ dt <- reifyDataType mainTyName
444+ let tyVars = dtTvs dt
445+ mapper = mapperWith (VarT <$> tyVars) subs
442− let cons = dtCons dt
446+ cons = map (modifyConVariables mapper) (dtCons dt)
443 deriveUnboxInternal headTy cons (mkInst mo preds headTyWC)
447 deriveUnboxInternal headTy cons (mkInst mo preds headTyWC)
444 _ -> errorMessage dec
448 _ -> errorMessage dec
445
449
446 where
450 where
447
451
452+ mapperWith l1 l2 a =
453+ case elemIndex a l1 of
454+ Nothing -> a
455+ -- XXX Capture this case and give a relavant error.
456+ Just i -> l2 !! i
457+
458+ mapType f (AppT t1 t2) = AppT (mapType f t1) (mapType f t2)
459+ mapType f (InfixT t1 n t2) = InfixT (mapType f t1) n (mapType f t2)
460+ mapType f (UInfixT t1 n t2) = UInfixT (mapType f t1) n (mapType f t2)
461+ mapType f (ParensT t) = ParensT (mapType f t)
462+ mapType f v = f v
463+
464+ modifyConVariables f con =
465+ con { dcFields = map (\(a, b) -> (a, mapType f b)) (dcFields con) }
466+
448 mkInst mo preds headTyWC methods =
467 mkInst mo preds headTyWC methods =
449 pure [InstanceD mo preds headTyWC methods]
468 pure [InstanceD mo preds headTyWC methods]
450
469
@@ -466,10 +485,10 @@ deriveUnbox mDecs = do
466 unwrap _ (AppT (ConT _) r) = r
485 unwrap _ (AppT (ConT _) r) = r
467 unwrap dec _ = errorMessage dec
486 unwrap dec _ = errorMessage dec
468
487
469− getMainTypeName dec = go
488+ getMainTypeName dec = go []
470
489
471 where
490 where
472
491
473− go (ConT nm) = nm
492+ go xs (ConT nm) = (nm, xs)
474− go (AppT l _) = go l
493+ go xs (AppT l r) = go (r:xs) l
475− go _ = errorMessage dec
494+ go _ _ = errorMessage dec