git.iko.soy/generic-lens
on master help sign in
Error if type has less parameters than required by 'param'
383f441Csongor Kiss
src/Data/Generics/Internal/Families/Changing.hs+5
compare with master
unifiedsplit
@@ -14,6 +14,7 @@ module Data.Generics.Internal.Families.Changing
14 , PTag (..)
14 , PTag (..)
15 , P
15 , P
16 , LookupParam
16 , LookupParam
17+ , ArgCount
17 ) where
18 ) where
18
19
19import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
20import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))
@@ -118,6 +119,10 @@ type family IfEq (a :: k) (b :: k) (t :: l) (f :: l) :: l where
118 IfEq a a t _ = t
119 IfEq a a t _ = t
119 IfEq _ _ _ f = f
120 IfEq _ _ _ f = f
120
121
122+type family ArgCount (t :: k) :: Nat where
123+ ArgCount (f a) = 1 + ArgCount f
124+ ArgCount a = 0
125+
121-- Note [CPP in instance constraints]
126-- Note [CPP in instance constraints]
122-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
127-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
123--
128--
src/Data/Generics/Product/Param.hs+18−1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE TypeFamilies #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
@@ -28,10 +29,11 @@ module Data.Generics.Product.Param
28 , HasParam (..)
29 , HasParam (..)
29 ) where
30 ) where
30
31
31−import GHC.TypeLits (Nat)
32+import GHC.TypeLits
32import Data.Generics.Internal.Void
33import Data.Generics.Internal.Void
33import Data.Generics.Internal.Families.Changing
34import Data.Generics.Internal.Families.Changing
34import Data.Generics.Internal.VL.Traversal
35import Data.Generics.Internal.VL.Traversal
36+import Data.Generics.Internal.VL.Lens
35
37
36import GHC.Generics
38import GHC.Generics
37import Data.Kind
39import Data.Kind
@@ -47,12 +49,27 @@ instance
47 -- TODO: merge the old 'Changing' code with 'GenericN'
49 -- TODO: merge the old 'Changing' code with 'GenericN'
48 , s ~ Infer t (P n b 'PTag) a
50 , s ~ Infer t (P n b 'PTag) a
49 , t ~ Infer s (P n a 'PTag) b
51 , t ~ Infer s (P n a 'PTag) b
52+ , Error ((ArgCount s) <=? n) n (ArgCount s) s
50 , GHasParam n (RepN s) (RepN t) a b
53 , GHasParam n (RepN s) (RepN t) a b
51 ) => HasParam n s t a b where
54 ) => HasParam n s t a b where
52
55
53 param = confusing (\f s -> toN <$> gparam @n f (fromN s))
56 param = confusing (\f s -> toN <$> gparam @n f (fromN s))
54 {-# INLINE param #-}
57 {-# INLINE param #-}
55
58
59+type family Error (b :: Bool) (expected :: Nat) (actual :: Nat) (s :: Type) :: Constraint where
60+ Error 'False _ _ _
61+ = ()
62+
63+ Error 'True expected actual typ
64+ = TypeError
65+ ( 'Text "Expected a type with at least "
66+ ':<>: 'ShowType (expected + 1)
67+ ':<>: 'Text " parameters, but "
68+ ':$$: 'ShowType typ
69+ ':<>: 'Text " only has "
70+ ':<>: 'ShowType actual
71+ )
72+
56instance {-# OVERLAPPING #-} HasParam p (Void1 a) (Void1 b) a b where
73instance {-# OVERLAPPING #-} HasParam p (Void1 a) (Void1 b) a b where
57 param = undefined
74 param = undefined
58
75