tags wip

Author: functora

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

@@ -65,29 +65,28 @@ type NewRatTags lhs rhs =
     RatTags lhs
   )
 
---
--- TODO : Use MaybeGetTag instead to pattern match on (Just _)?
---
-type family MoneyTagsFamily tags tag where
-  MoneyTagsFamily tags 'MoneyAmount = tags
-  MoneyTagsFamily tags 'Currency = tags
-  MoneyTagsFamily tags 'QuotePerBase = tags
-  MoneyTagsFamily tags 'FeeRate = tags
-  MoneyTagsFamily tags 'ProfitRate = tags
+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 (GetTag MoneyKind tags)
+            ( MoneyTagsFamily tags (MaybeGetTag MoneyKind tags)
             )
         )
     )
 
 type MoneyTags tags =
   ( RatTags tags,
-    tags ~ MoneyTagsFamily tags (GetTag MoneyKind tags)
+    tags ~ MoneyTagsFamily tags (MaybeGetTag MoneyKind tags)
   )
 
 type NewMoneyTags lhs rhs =

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

@@ -12,6 +12,7 @@ module Functora.TagsFamily
 
     -- * Accessors
     -- $accessors
+    MaybeGetTag,
     GetTag,
     HasTag,
 
@@ -69,7 +70,9 @@ type family lhs |&| rhs where
 -- $accessors
 -- Accessors
 
-type GetTag k tags = GetTagFamily ('Nothing :: Maybe k) k tags tags
+type MaybeGetTag k tags = MaybeGetTagFamily ('Nothing :: Maybe k) k tags tags
+
+type GetTag k tags = GetTagFamily k tags (MaybeGetTag k tags)
 
 type HasTag (v :: k) tags =
   ( SingI v,
@@ -152,26 +155,38 @@ type family UnTagFamily member v tags prev next where
   UnTagFamily member v tags (kv ': prev) next =
     UnTagFamily member v tags prev (kv ': next)
 
-type family GetTagFamily mv k tags prev where
-  GetTagFamily ('Just (v :: k)) k _ '[] = v
-  GetTagFamily 'Nothing k tags '[] =
+type family MaybeGetTagFamily mv k tags prev where
+  MaybeGetTagFamily ('Just (v :: k)) k _ '[] = 'Just v
+  MaybeGetTagFamily 'Nothing _ _ '[] = 'Nothing
+  MaybeGetTagFamily ('Just v) k tags ((k ':-> Sing v) ': _) =
     TypeError
-      ( 'ShowType k
-          ':<>: 'Text " key is missing in "
+      ( 'ShowType v
+          ':<>: 'Text " :: "
+          ':<>: 'ShowType k
+          ':<>: 'Text " tag conflicts with "
           ':<>: 'ShowType tags
       )
-  GetTagFamily ('Just v) k tags ((k ':-> Sing v) ': _) =
+  MaybeGetTagFamily 'Nothing k tags ((k ':-> Sing v) ': next) =
+    MaybeGetTagFamily ('Just v) k tags next
+  MaybeGetTagFamily mv k tags (_ ': next) =
+    MaybeGetTagFamily mv k tags next
+
+type family GetTagFamily k tags mv where
+  GetTagFamily k _ ('Just (v :: k)) = v
+  GetTagFamily k tags ('Just v) =
     TypeError
       ( 'ShowType v
           ':<>: 'Text " :: "
           ':<>: 'ShowType k
           ':<>: 'Text " tag conflicts with "
           ':<>: 'ShowType tags
       )
-  GetTagFamily 'Nothing k tags ((k ':-> Sing v) ': next) =
-    GetTagFamily ('Just v) k tags next
-  GetTagFamily mv k tags (_ ': next) =
-    GetTagFamily mv k tags next
+  GetTagFamily k tags 'Nothing =
+    TypeError
+      ( 'ShowType k
+          ':<>: 'Text " key is missing in "
+          ':<>: 'ShowType tags
+      )
 
 --
 -- TODO : NEED A PROPER INSTANCE!