@@ -1,97 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE FunctionalDependencies #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE Rank2Types #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeApplications #-}
11−{-# LANGUAGE TypeFamilyDependencies #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−
15−-----------------------------------------------------------------------------
16−-- |
17−-- Module : Data.Generics.Product.Internal.Types
18−-- Copyright : (C) 2017 Csongor Kiss
19−-- License : BSD3
20−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
21−-- Stability : experimental
22−-- Portability : non-portable
23−--
24−-- Derive traversals of a given type in a product.
25−--
26−-----------------------------------------------------------------------------
27−
28−module Data.Generics.Product.Internal.Types
29− (
30− GHasConstraints (..)
31− , HList (..)
32− ) where
33−
34−import Data.Kind (Type, Constraint)
35−import GHC.Generics
36−import Data.Generics.Internal.VL.Iso
37−
38−-- | Constrained traversal.
39−class GHasConstraints (c :: * -> Constraint) (f :: * -> *) where
40− gconstraints :: forall g x.
41− Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)
42−
43−instance (GHasConstraints c l, GHasConstraints c r) => GHasConstraints c (l :*: r) where
44− gconstraints f (l :*: r) = (:*:) <$> gconstraints @c f l <*> gconstraints @c f r
45−
46−instance (GHasConstraints c l, GHasConstraints c r) => GHasConstraints c (l :+: r) where
47− gconstraints f (L1 l) = L1 <$> gconstraints @c f l
48− gconstraints f (R1 r) = R1 <$> gconstraints @c f r
49−
50−instance c a => GHasConstraints c (K1 R a) where
51− gconstraints = kIso
52−
53−instance GHasConstraints c f => GHasConstraints c (M1 m meta f) where
54− gconstraints f (M1 x) = M1 <$> gconstraints @c f x
55−
56−instance GHasConstraints c U1 where
57− gconstraints _ _ = pure U1
58−
59−--------------------------------------------------------------------------------
60−
61−-- | Multi-traversal
62−--type GHasTypes rep as = GHasConstraints (Contains as) rep
63−
64−-- Try to use a function from the list, or default to 'pure' if not present
65−{-
66−gtypes
67− :: forall as x f g.
68− ( GHasTypes f as
69− , Applicative g
70− ) => HList (Functions as g) -> f x -> g (f x)
71−gtypes hl s = gconstraints @(Contains as) (pick hl) s
72−-}
73−
74−--------------------------------------------------------------------------------
75−
76−data HList (ts :: [Type]) where
77− HNil :: HList '[]
78− (:>) :: a -> HList as -> HList (a ': as)
79−infixr 5 :>
80−
81−-- >>> :kind! Functions '[Int, Char, Bool] Maybe
82−-- '[Int -> Maybe Int, Char -> Maybe Char, Bool -> Maybe Bool]
83−type family Functions (ts :: [Type]) (g :: Type -> Type) = r | r -> ts where
84− Functions '[] _ = '[]
85− Functions (t ': ts) g = ((t -> g t) ': Functions ts g)
86−
87−class Contains as a where
88− pick :: Applicative g => HList (Functions as g) -> a -> g a
89−
90−instance {-# OVERLAPPING #-} Contains (a ': as) a where
91− pick (h :> _) = h
92−
93−instance Contains as a => Contains (b ': as) a where
94− pick (_ :> hs) = pick hs
95−
96−instance Contains '[] a where
97− pick _ = pure