tuple-classes-1.0.2: src/Data/Tuple/Classes/TH.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Tuple.Classes.TH (
makeStrictTupleAndInsts,
makeUncurryNInst,
makeTupleAtInsts,
) where
import Control.DeepSeq (NFData(..), NFData1, NFData2(..))
import Control.Monad (forM)
import Data.Bifoldable (Bifoldable(..))
import Data.Bifunctor.Swap (Swap(..))
import Data.Binary (Binary(..))
import Data.Bitraversable (Bitraversable(..))
import Data.Data (Data)
import Data.Functor.Classes
import Data.Hashable (Hashable(..))
import Data.Hashable.Lifted (Hashable1, Hashable2(..))
import Data.Ix (Ix)
import Data.Strict.Classes (Strict(..))
import Data.Strict.Tuple (Pair(..))
import GHC.Generics (Generic, Generic1)
import GHC.Read qualified as Read
import Language.Haskell.TH hiding (Strict)
import Language.Haskell.TH.Syntax hiding (Strict)
import Text.Read (Read(..))
import Text.Read qualified as Read
#if !MIN_VERSION_base(4,20,0)
import Data.Foldable (foldl')
#endif
#if defined(LENS)
import Control.Lens hiding (op)
#else
import Data.Bifunctor (Bifunctor(..))
import Data.Functor.Identity (Identity(..))
import Lens.Micro
import Lens.Micro.Internal qualified as Lens.Micro
#if !MIN_VERSION_microlens(0,5,0)
import Lens.Micro.Internal hiding (Strict)
#endif
#endif
dropLast :: Int -> [a] -> [a]
dropLast n = reverse . drop n . reverse
strictTName :: Int -> Name
strictTName 0 = ''()
strictTName 1 = ''Identity
strictTName 2 = ''Pair
strictTName n = mkName $ "StrictTuple" ++ show n
strictDName :: Int -> Name
strictDName 0 = '()
strictDName 1 = 'Identity
strictDName 2 = '(:!:)
strictDName n = strictTName n
-- "StrictTuple3"
strictTupleSE :: (?n :: Int) => ExpQ
strictTupleSE = stringE $ nameBase $ strictDName ?n
mkNames :: (?n :: Int, Enum a) => a -> (a -> String) -> [Name]
mkNames x toName = map (mkName . toName) $ take ?n $ enumFrom x
abc, xs, ys :: (?n :: Int) => [Name]
-- a, b, c
abc = mkNames 'a' (: [])
-- x1, x2, x3
xs = mkNames (1 :: Int) $ ('x' :) . show
-- y1, y2, y3
ys = mkNames (1 :: Int) $ ('y' :) . show
cur, unc :: Name
(cur, unc) = ("cur", "unc") & both %~ mkName
-- !a
banged :: Name -> BangTypeQ
banged a = bangType (bang noSourceUnpackedness sourceStrict) (varT a)
-- contextT 1 ''Eq = (Eq a, Eq b)
contextT :: (?n :: Int) => Int -> Name -> TypeQ
contextT u ctor = foldl' appT (tupleT $ ?n - u) $
map (\a -> conT ctor `appT` varT a) $ dropLast u abc
-- StrictTuple3 a
strictTupleUnsatT :: (?n :: Int) => Int -> TypeQ
strictTupleUnsatT u =
foldl' appT (conT $ strictTName ?n) $ dropLast u $ map varT abc
-- StrictTuple3 a b c
strictTupleSatT :: (?n :: Int) => TypeQ
strictTupleSatT = strictTupleUnsatT 0
-- (a, b, c)
lazyTupleSatT :: (?n :: Int) => TypeQ
lazyTupleSatT = foldl' appT (tupleT ?n) $ map varT abc
-- a
aT, bT :: TypeQ
(aT, bT) = ("a", "b") & both %~ varT . mkName
-- StrictTuple3 x1 x2 x3
strictTupleP :: (?n :: Int) => [Name] -> PatQ
strictTupleP = conP (strictDName ?n) . map varP
-- StrictTuple3 x1
strictTupleUnsatE :: (?n :: Int) => Int -> ExpQ
strictTupleUnsatE u =
foldl' appE (conE $ strictDName ?n) $ dropLast u $ map varE xs
-- StrictTuple3 x1 x2 x3
strictTupleSatE :: (?n :: Int) => ExpQ
strictTupleSatE = strictTupleUnsatE 0
-- StrictTuple3 a a a
strictTupleAllSameT :: (?n :: Int) => TypeQ -> TypeQ
strictTupleAllSameT a = foldl' appT (conT $ strictTName ?n) (replicate ?n a)
-- {-# INLINE method #-}
inlineD :: Name -> DecQ
inlineD name = pragInlD name Inline FunLike AllPhases
-- StrictTuple3 <$> exp1 <*> exp2 <*> ...
applicativeE :: (?n :: Int) => [ExpQ] -> ExpQ
applicativeE expQs = foldl' accOpE (conE $ strictDName ?n) $ zip ops expQs where
accOpE acc (op, expQ) = uInfixE acc op expQ
ops = [| (<$>) |] : repeat [| (<*>) |]
-- x <> y
sappendE :: Name -> Name -> ExpQ
sappendE x y = [| $(varE x) <> $(varE y) |]
-- (1, ''Field1, '_1), (2, ''Field2, '_2), ...
fieldNNames :: [(Int, Name, Name)]
fieldNNames = $(
let go i = do
fieldI <- lookupTypeName $ "Field" ++ show i
_i <- lookupValueName $ "_" ++ show i
case liftA2 (i, , ) fieldI _i of
Nothing -> return []
Just iFieldI_i -> (iFieldI_i :) <$> go (i + 1)
liftFieldNNames :: [(Int, Name, Name)] -> ExpQ
#if MIN_VERSION_template_haskell(2,22,1)
liftFieldNNames = lift
#else
liftFieldNNames = listE . map liftTriple
liftTriple (i, fieldI, _i) = tupE [lift i, liftName fieldI, liftName _i]
liftName (Name (OccName on) (NameG ns (PkgName pn) (ModName mn))) = [|
Name
(OccName $(stringE on))
(NameG
$(liftNameSpace ns)
(PkgName $(stringE pn))
(ModName $(stringE mn)))
|]
liftName _ = fail "not implemented"
liftNameSpace VarName = [| VarName |]
liftNameSpace TcClsName = [| TcClsName |]
liftNameSpace _ = fail "not implemented"
#endif
in go (1 :: Int) >>= liftFieldNNames)
{-
instance UncurryN 3 (a -> b -> c -> d) where
type UncurriedN 3 (a -> b -> c -> d) = (a, b, c) -> d
type UncurriedN' 3 (a -> b -> c -> d) = StrictTuple3 a b c -> d
uncurryN cur ~(x1, x2, x3) = cur x1 x2 x3
curryN unc x1 x2 x3 = unc (x1, x2, x3)
uncurryN' cur ~(StrictTuple3 x1 x2 x3) = cur x1 x2 x3
curryN' unc x1 x2 x3 = unc (StrictTuple3 x1 x2 x3)
-}
makeUncurryNInst :: (?n :: Int) => DecQ
makeUncurryNInst =
let d = mkName [['a' ..] !! ?n]
nT = litT $ numTyLit $ fromIntegral ?n
curT = foldr (\a r -> [t| $(varT a) -> $r |]) (varT d) abc
uncurryClause ctor = clause
[varP cur, tildeP $ conP ctor $ map varP xs]
(normalB $ foldl' appE (varE cur) $ map varE xs)
[]
curryClause ctor = clause
(map varP $ unc : xs)
(normalB $ varE unc `appE` foldl' appE (conE ctor) (map varE xs))
[]
in instanceD (pure []) [t| $(conT $ mkName "UncurryN") $nT $curT |] [
tySynInstD $ tySynEqn
Nothing
[t| $(conT $ mkName "UncurriedN") $nT $curT |]
[t| $lazyTupleSatT -> $(varT d) |],
tySynInstD $ tySynEqn
Nothing
[t| $(conT $ mkName "UncurriedN'") $nT $curT |]
[t| $strictTupleSatT -> $(varT d) |],
funD (mkName "uncurryN") [uncurryClause $ tupleDataName ?n],
funD (mkName "curryN") [curryClause $ tupleDataName ?n],
funD (mkName "uncurryN'") [uncurryClause $ strictDName ?n],
funD (mkName "curryN'") [curryClause $ strictDName ?n]]
makeTupleAtInsts :: (?n :: Int) => DecsQ
makeTupleAtInsts = fmap concat $ forM [1 .. ?n] $ \i -> do
((a, x), (abc', xs')) <- case splitAt (i - 1) $ zip abc xs of
(ls, ax : rs) -> return (ax, unzip $ ls ++ rs)
_ -> fail $
"makeTupleAtInsts: no element at index " ++ show i
let tupleAtInst :: Name -> Name -> Name -> Name -> DecQ
tupleAtInst removeType removeData insertType insertData = instanceD
(pure [])
(conT (mkName "TupleAt")
`appT` litT (numTyLit $ fromIntegral i)
`appT` varT a
`appT` foldl' appT (conT removeType) (map varT abc')
`appT` foldl' appT (conT insertType) (map varT abc))
[
funD (mkName "tupleInsert") [clause
[varP x, tildeP $ conP removeData $ map varP xs']
(normalB $ foldl' appE (conE insertData) $ map varE xs)
[]],
funD (mkName "tupleRemove") [clause
[conP insertData $ map varP xs]
(normalB $ tupE [
varE x,
foldl' appE (conE removeData) $ map varE xs'])
[]]]
sequence [
{-
instance TupleAt 2 b (a, c) (a, b, c) where
tupleInsert x2 ~(x1, x3) = (x1, x2, x3)
tupleRemove (x1, x2, x3) = (x2, (x1, x3))
-}
tupleAtInst
(tupleTypeName $ ?n - 1)
(tupleDataName $ ?n - 1)
(tupleTypeName ?n)
(tupleDataName ?n),
-- TODO This tilde makes implementation simpler and probably has no
-- impact, but let's confirm that with benchmarks.
{-
instance TupleAt 2 b (Pair a c) (StrictTuple3 a b c) where
tupleInsert x2 ~(x1 :!: x3) = StrictTuple3 x1 x2 x3
tupleRemove (StrictTuple3 x1 x2 x3) = (x2, x1 :!: x3)
-}
tupleAtInst
(strictTName $ ?n - 1)
(strictDName $ ?n - 1)
(strictTName ?n)
(strictDName ?n)]
makeStrictTupleAndInsts :: (?n :: Int) => DecsQ
makeStrictTupleAndInsts = do
((x1, y1), (x2, y2)) <- case drop (?n - 2) $ zip xs ys of
[xy1, xy2] -> return (xy1, xy2)
_ -> fail "makeStrictTupleAndInsts: ?n < 2"
{-
data StrictTuple3 a b c = StrictTuple3 a b c
deriving (...)
-}
strictTupleDef <- dataD
(pure [])
(strictTName ?n)
[PlainTV a BndrReq | a <- abc]
Nothing
[normalC (strictDName ?n) $ map banged abc]
[derivClause Nothing $ map conT [
''Eq,
''Ord,
''Read,
''Show,
''Bounded,
''Ix,
''Foldable,
''Functor,
''Traversable,
''Generic,
''Generic1,
''Data]]
{-
instance Field2 (StrictTuple3 a b c) (StrictTuple3 a b' c) b b' where
_2 f ~(StrictTuple3 x1 x2 x3) = f x2 <&> \x2' -> StrictTuple3 x1 x2' x3
{-# INLINE _2 #-}
-}
fieldNInsts <- forM (take ?n fieldNNames) $ \(i, fieldI, _i) -> do
((a, x), (a', x'), (a'bc, xs')) <- case splitAt (i - 1) $ zip abc xs of
(_, []) -> fail "fieldNInsts: i > ?n"
(ls, ax : rs) -> return (ax, a'x', unzip $ ls ++ a'x' : rs) where
a'x' = ax & both %~ \name -> mkName $ nameBase name ++ "'"
f <- newName "f"
instanceD
(pure [])
(conT fieldI
`appT` strictTupleSatT
`appT` foldl' appT (conT $ strictTName ?n) (map varT a'bc)
`appT` varT a
`appT` varT a')
[
funD _i [clause
[varP f, tildeP $ strictTupleP xs]
(normalB $ [| fmap |]
`appE` lam1E
(varP x')
(foldl' appE (conE $ strictDName ?n) $ map varE xs')
`appE` (varE f `appE` varE x))
[]],
inlineD _i]
otherInsts <- [d|
{-
instance (Eq a, Eq b) => Eq1 (StrictTuple3 a b) where
-}
instance $(contextT 1 ''Eq) => Eq1 $(strictTupleUnsatT 1)
{-
instance (Eq a) => Eq2 (StrictTuple3 a) where
liftEq2 f g (StrictTuple3 x1 x2 x3) (StrictTuple3 y1 y2 y3) =
x1 == y1 && f x2 y2 && g x3 y3
-}
instance $(contextT 2 ''Eq) => Eq2 $(strictTupleUnsatT 2) where
liftEq2 f g $(strictTupleP xs) $(strictTupleP ys) = $(foldr
(\expQ r -> [| $expQ && $r |])
[| f $(varE x1) $(varE y1) && g $(varE x2) $(varE y2) |]
(dropLast 2 $
let eqE x y = [| $(varE x) == $(varE y) |]
in zipWith eqE xs ys))
{-
instance (Ord a, Ord b) => Ord1 (StrictTuple3 a b) where
-}
instance $(contextT 1 ''Ord) => Ord1 $(strictTupleUnsatT 1)
{-
instance (Ord a) => Ord2 (StrictTuple3 a) where
liftCompare2 f g (StrictTuple3 x1 x2 x3) (StrictTuple3 y1 y2 y3) =
x1 `compare` y1 <> f x2 y2 <> g x3 y3
-}
instance $(contextT 2 ''Ord) => Ord2 $(strictTupleUnsatT 2) where
liftCompare2 f g $(strictTupleP xs) $(strictTupleP ys) = $(foldr
(\expQ r -> [| $expQ <> $r |])
[| f $(varE x1) $(varE y1) <> g $(varE x2) $(varE y2) |]
(dropLast 2 $
let compareE x y = [| $(varE x) `compare` $(varE y) |]
in zipWith compareE xs ys))
{-
instance (Show a, Show b) => Show1 (StrictTuple3 a b)
-}
instance $(contextT 1 ''Show) => Show1 $(strictTupleUnsatT 1)
{-
instance (Show a) => Show2 (StrictTuple3 a) where
liftShowsPrec2 f _ g _ prec (StrictTuple3 x1 x2 x3) =
showParen (prec > 10) $ showString "StrictTuple3"
. showChar ' ' . showsPrec 11 x1
. showChar ' ' . f 11 x2
. showChar ' ' . g 11 x3
-}
instance $(contextT 2 ''Show) => Show2 $(strictTupleUnsatT 2) where
liftShowsPrec2 f _ g _ prec $(strictTupleP xs) =
showParen (prec > 10) $(
let unwordsE fE r = [| $fE . showChar ' ' . $r |]
showsCtorE = [| showString $strictTupleSE |]
showsPrecE x = [| showsPrec 11 $(varE x) |]
mostFsE = map showsPrecE $ dropLast 2 xs
in foldr1 unwordsE $ showsCtorE : mostFsE ++ [
[| f 11 $(varE x1) |],
[| g 11 $(varE x2) |]])
{-
instance (Read a, Read b) => Read1 (StrictTuple3 a b) where
liftReadPrec = liftReadPrec2 readPrec readListPrec
liftReadListPrec = liftReadListPrecDefault
liftReadList = liftReadListDefault
-}
instance $(contextT 1 ''Read) => Read1 $(strictTupleUnsatT 1) where
liftReadPrec = liftReadPrec2 readPrec readListPrec
liftReadListPrec = liftReadListPrecDefault
liftReadList = liftReadListDefault
{-
instance (Read a) => Read2 (StrictTuple3 a) where
liftReadPrec2 rp1 _ rp2 _ = readData $ do
Read.expectP $ Read.Ident "StrictTuple3"
Read.step $ StrictTuple3 <$> readPrec <*> rp1 <*> rp2
-}
instance $(contextT 2 ''Read) => Read2 $(strictTupleUnsatT 2) where
liftReadPrec2 rp1 _ rp2 _ = readData $ do
Read.expectP $ Read.Ident $(stringE $ nameBase $ strictDName ?n)
Read.step $ $(applicativeE $ replicate (?n - 2) [| readPrec |])
<*> rp1
<*> rp2
{-
instance (NFData a, NFData b, NFData c) =>
NFData (StrictTuple3 a b c)
-}
instance $(contextT 0 ''NFData) => NFData $strictTupleSatT
{-
instance (NFData a) => NFData2 (StrictTuple3 a) where
liftRnf2 f g (StrictTuple3 x1 x2 x3) = x1 `seq` f x2 `seq` g x3
-}
instance $(contextT 2 ''NFData) => NFData2 $(strictTupleUnsatT 2) where
liftRnf2 f g $(strictTupleP xs) = $(foldr
(\x r -> [| rnf $(varE x) `seq` $r |])
[| f $(varE x1) `seq` g $(varE x2) |]
(dropLast 2 xs))
{-
instance (NFData a, NFData b) => NFData1 (StrictTuple3 a b)
-}
instance $(contextT 1 ''NFData) => NFData1 $(strictTupleUnsatT 1)
{-
instance (Semigroup a, Semigroup b, Semigroup c) =>
Semigroup (StrictTuple3 a b c) where
StrictTuple3 x1 x2 x3 <> StrictTuple3 y1 y2 y3 =
StrictTuple3 (x1 <> y1) (x2 <> y2) (x3 <> y3)
-}
instance $(contextT 0 ''Semigroup) => Semigroup $strictTupleSatT where
$(strictTupleP xs) <> $(strictTupleP ys) =
$(foldl' appE (conE $ strictDName ?n) $ zipWith sappendE xs ys)
{-
instance (Monoid a, Monoid b, Monoid c) => Monoid (StrictTuple3 a b c) where
mempty = StrictTuple3 mempty mempty mempty
-}
instance $(contextT 0 ''Monoid) => Monoid $strictTupleSatT where
mempty = $(foldl' appE (conE $ strictDName ?n) $
replicate ?n [| mempty |])
{-
instance (Monoid a, Monoid b) => Applicative (StrictTuple3 a b) where
pure = StrictTuple3 mempty mempty
StrictTuple3 x1 x2 x3 <*> StrictTuple3 y1 y2 y3 =
StrictTuple (x1 <> y1) (x2 <> y2) (x3 y3)
-}
instance $(contextT 1 ''Monoid) => Applicative $(strictTupleUnsatT 1)
where
pure = $(foldl' appE (conE $ strictDName ?n) $
replicate (?n - 1) [| mempty |])
$(strictTupleP xs) <*> $(strictTupleP ys) =
$(foldl' appE (conE $ strictDName ?n) $
let sappendE's = init $ zipWith sappendE xs ys
in sappendE's ++ [varE (last xs) `appE` varE (last ys)])
{-
instance (Monoid a, Monoid b) => Monad (StrictTuple3 a b) where
StrictTuple3 x1 x2 x3 >>= f = StrictTuple3 (x1 <> y1) (x2 <> y2) y3
where
StrictTuple3 y1 y2 y3 = f x3
-}
instance $(contextT 1 ''Monoid) => Monad $(strictTupleUnsatT 1) where
$(strictTupleP xs) >>= f = $(foldl' appE (conE $ strictDName ?n) $
init (zipWith sappendE xs ys) ++ [varE $ last ys])
where
$(strictTupleP ys) = f $(varE $ last xs)
{-
instance (Binary a, Binary b, Binary c) => Binary (StrictTuple3 a b c) where
put = put . toLazy
get = toStrict <$> get
-}
instance $(contextT 0 ''Binary) => Binary $strictTupleSatT where
put = put . toLazy
get = toStrict <$> get
{-
instance (Hashable a, Hashable b, Hashable c) =>
Hashable (StrictTuple3 a b c)
-}
instance $(contextT 0 ''Hashable) => Hashable $strictTupleSatT
{-
instance (Hashable a, Hashable b) => Hashable1 (StrictTuple3 a b)
-}
instance $(contextT 1 ''Hashable) => Hashable1 $(strictTupleUnsatT 1)
{-
instance (Hashable a) => Hashable2 (StrictTuple3 a) where
liftHashWithSalt2 f g s (StrictTuple3 x1 x2 x3) =
(s `hashWithSalt` x1) `f` x2 `g` x3
-}
instance $(contextT 2 ''Hashable) =>
Hashable2 $(strictTupleUnsatT 2) where
liftHashWithSalt2 f g s $(strictTupleP xs) = $(
let accHashE acc x = [| $(acc) `hashWithSalt` $(varE x) |]
in parensE $ foldl' accHashE [| s |] $ dropLast 2 xs)
`f` $(varE x1)
`g` $(varE x2)
{-
instance Strict (a, b, c) (StrictTuple3 a b c) where
toStrict (x1, x2, x3) = StrictTuple3 x1 x2 x3
toLazy (StrictTuple3 x1 x2 x3) = (x1, x2, x3)
-}
instance Strict $lazyTupleSatT $strictTupleSatT where
toStrict $(tupP $ map varP xs) = $strictTupleSatE
toLazy $(strictTupleP xs) = $(tupE $ map varE xs)
#if !defined(LENS)
{-
instance Lens.Micro.Strict (a, b, c) (StrictTuple3 a b c) where
strict = lens toStrict (const toLazy)
lazy = lens toLazy (const toStrict)
-}
instance Lens.Micro.Strict $lazyTupleSatT $strictTupleSatT where
strict f = fmap toLazy . f . toStrict
{-# INLINE strict #-}
lazy f = fmap toStrict . f . toLazy
{-# INLINE lazy #-}
#endif
{-
instance Swap (StrictTuple3 a) where
swap (StrictTuple3 x1 x2 x3) = StrictTuple3 x1 x3 x2
-}
instance Swap $(strictTupleUnsatT 2) where
swap $(strictTupleP xs) =
$(strictTupleUnsatE 2) $(varE x2) $(varE x1)
{-
instance Bifoldable (StrictTuple3 a) where
bifoldMap f g ~(StrictTuple3 _ x1 x2) = f x1 <> g x2
-}
instance Bifoldable $(strictTupleUnsatT 2) where
bifoldMap f g $(tildeP $ conP (strictDName ?n) $
replicate (?n - 2) wildP ++ [varP x1, varP x2])
= f $(varE x1) <> g $(varE x2)
{-
instance Bifunctor (StrictTuple3 a) where
bimap f g ~(StrictTuple3 x1 x2 x3) = StrictTuple3 x1 (f x2) (g x3)
-}
instance Bifunctor $(strictTupleUnsatT 2) where
bimap f g $(tildeP $ strictTupleP xs) =
$(strictTupleUnsatE 2) (f $(varE x1)) (g $(varE x2))
{-
instance Bitraversable (StrictTuple3 a) where
bitraverse f g ~(StrictTuple3 x1 x2 x3) =
liftA2 (StrictTuple3 x1) (f x2) (g x3)
-}
instance Bitraversable $(strictTupleUnsatT 2) where
bitraverse f g $(tildeP $ strictTupleP xs) =
$(strictTupleUnsatE 2) <$> f $(varE x1) <*> g $(varE x2)
{-
instance Each (StrictTuple3 a a a) (StrictTuple3 b b b) a b where
each f ~(StrictTuple3 x1 x2 x3) =
StrictTuple3 <$> f x1 <*> f x2 <*> f x3
-}
instance Each
$(strictTupleAllSameT aT)
$(strictTupleAllSameT bT)
$aT
$bT
where
each f $(tildeP $ strictTupleP xs) =
$(applicativeE [[| f $(varE x) |] | x <- xs])
{-# INLINE each #-}
|]
return $ strictTupleDef : fieldNInsts ++ otherInsts