git.iko.soy/generic-lens
on master help sign in
Add Data.Generics.Product.Internal.Constraints
f5c880eCsongor Kiss
src/Data/Generics/Product/Internal/Constraints.hsnew file+99
compare with master
unifiedsplit
@@ -0,0 +1,99 @@
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.Constraints
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 constrained traversals
25+--
26+-----------------------------------------------------------------------------
27+
28+-- TODO: use type-changing variant
29+
30+module Data.Generics.Product.Internal.Constraints
31+ (
32+ GHasConstraints (..)
33+ , HList (..)
34+ ) where
35+
36+import Data.Kind (Type, Constraint)
37+import GHC.Generics
38+import Data.Generics.Internal.VL.Iso
39+
40+-- | Constrained traversal.
41+class GHasConstraints (c :: * -> Constraint) (f :: * -> *) where
42+ gconstraints :: forall g x.
43+ Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)
44+
45+instance (GHasConstraints c l, GHasConstraints c r) => GHasConstraints c (l :*: r) where
46+ gconstraints f (l :*: r) = (:*:) <$> gconstraints @c f l <*> gconstraints @c f r
47+
48+instance (GHasConstraints c l, GHasConstraints c r) => GHasConstraints c (l :+: r) where
49+ gconstraints f (L1 l) = L1 <$> gconstraints @c f l
50+ gconstraints f (R1 r) = R1 <$> gconstraints @c f r
51+
52+instance c a => GHasConstraints c (K1 R a) where
53+ gconstraints = kIso
54+
55+instance GHasConstraints c f => GHasConstraints c (M1 m meta f) where
56+ gconstraints f (M1 x) = M1 <$> gconstraints @c f x
57+
58+instance GHasConstraints c U1 where
59+ gconstraints _ _ = pure U1
60+
61+--------------------------------------------------------------------------------
62+
63+-- | Multi-traversal
64+--type GHasTypes rep as = GHasConstraints (Contains as) rep
65+
66+-- Try to use a function from the list, or default to 'pure' if not present
67+{-
68+gtypes
69+ :: forall as x f g.
70+ ( GHasTypes f as
71+ , Applicative g
72+ ) => HList (Functions as g) -> f x -> g (f x)
73+gtypes hl s = gconstraints @(Contains as) (pick hl) s
74+-}
75+
76+--------------------------------------------------------------------------------
77+
78+data HList (ts :: [Type]) where
79+ HNil :: HList '[]
80+ (:>) :: a -> HList as -> HList (a ': as)
81+infixr 5 :>
82+
83+-- >>> :kind! Functions '[Int, Char, Bool] Maybe
84+-- '[Int -> Maybe Int, Char -> Maybe Char, Bool -> Maybe Bool]
85+type family Functions (ts :: [Type]) (g :: Type -> Type) = r | r -> ts where
86+ Functions '[] _ = '[]
87+ Functions (t ': ts) g = ((t -> g t) ': Functions ts g)
88+
89+class Contains as a where
90+ pick :: Applicative g => HList (Functions as g) -> a -> g a
91+
92+instance {-# OVERLAPPING #-} Contains (a ': as) a where
93+ pick (h :> _) = h
94+
95+instance Contains as a => Contains (b ': as) a where
96+ pick (_ :> hs) = pick hs
97+
98+instance Contains '[] a where
99+ pick _ = pure