RefineTags combinator

Author: functora

pub/functora/src/money/Functora/Money.hs

@@ -65,28 +65,19 @@ type NewRatTags lhs rhs =
     RatTags lhs
   )
 
-type family MoneyTagsFamily tags mtag where
-  MoneyTagsFamily tags ('Just _) = tags
-  MoneyTagsFamily tags ('Nothing :: Maybe k) =
-    TypeError
-      ( 'ShowType k
-          ':<>: 'Text " key is missing in "
-          ':<>: 'ShowType tags
-      )
-
 type Money tags =
   Tagged
     tags
     ( Ratio
         ( IntRep
-            ( MoneyTagsFamily tags (MaybeGetTag MoneyKind tags)
+            ( RefineTags tags '[SignedOrUnsigned, MoneyKind]
             )
         )
     )
 
 type MoneyTags tags =
   ( RatTags tags,
-    tags ~ MoneyTagsFamily tags (MaybeGetTag MoneyKind tags)
+    tags ~ RefineTags tags '[SignedOrUnsigned, MoneyKind]
   )
 
 type NewMoneyTags lhs rhs =

pub/functora/src/tags/Functora/TagsFamily.hs

@@ -15,6 +15,7 @@ module Functora.TagsFamily
     MaybeGetTag,
     GetTag,
     HasTag,
+    RefineTags,
 
     -- * Fingerprints
     -- $fingerprints
@@ -82,6 +83,8 @@ type HasTag (v :: k) tags =
     v ~ GetTag k tags
   )
 
+type RefineTags tags keys = RefineTagsFamily tags keys
+
 -- $fingerprints
 -- Fingerprints
 
@@ -188,6 +191,22 @@ type family GetTagFamily k tags mv where
           ':<>: 'ShowType tags
       )
 
+type family RefineTagsFamily tags keys where
+  RefineTagsFamily tags '[] = tags
+  RefineTagsFamily tags (k ': keys) =
+    RefineTagsFamilyRec tags k keys (MaybeGetTag k tags)
+
+type family RefineTagsFamilyRec tags k keys mv where
+  RefineTagsFamilyRec tags _ '[] ('Just _) = tags
+  RefineTagsFamilyRec tags _ (k ': keys) ('Just _) =
+    RefineTagsFamilyRec tags k keys (MaybeGetTag k tags)
+  RefineTagsFamilyRec tags k _ 'Nothing =
+    TypeError
+      ( 'ShowType k
+          ':<>: 'Text " key is missing in "
+          ':<>: 'ShowType tags
+      )
+
 --
 -- TODO : NEED A PROPER INSTANCE!
 -- At the moment I don't know how to get