1 files changed, 99 insertions, 0 deletions
diff --git a/users/Profpatsch/my-prelude/Label.hs b/users/Profpatsch/my-prelude/Label.hs
new file mode 100644
index 000000000000..f869343a1e7a
--- /dev/null
+++ b/users/Profpatsch/my-prelude/Label.hs
@@ -0,0 +1,99 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Label
+  ( Label,
+    label,
+    label',
+    getLabel,
+    T2 (..),
+    T3 (..),
+  )
+where
+
+import Data.Data (Proxy (..))
+import Data.Function ((&))
+import Data.Typeable (Typeable)
+import GHC.Records (HasField (..))
+import GHC.TypeLits (Symbol)
+
+-- | A labelled value.
+--
+-- Use 'label'/'label'' to construct,
+-- then use dot-syntax to get the inner value.
+newtype Label (label :: Symbol) value = Label value
+  deriving stock (Show, Eq, Ord)
+  deriving newtype (Typeable)
+
+-- | Attach a label to a value; should be used with a type application to name the label.
+--
+-- @@
+-- let f = label @"foo" 'f' :: Label "foo" Char
+-- in f.foo :: Char
+-- @@
+--
+-- Use dot-syntax to get the labelled value.
+label :: forall label value. value -> Label label value
+label value = Label value
+
+-- | Attach a label to a value; Pass it a proxy with the label name in the argument type.
+-- This is intended for passing through the label value;
+-- you can also use 'label'.
+--
+--
+-- @@
+-- let f = label' (Proxy @"foo") 'f' :: Label "foo" Char
+-- in f.foo :: Char
+-- @@
+--
+-- Use dot-syntax to get the labelled value.
+label' :: forall label value. (Proxy label) -> value -> Label label value
+label' Proxy value = Label value
+
+-- | Fetches the labelled value.
+instance HasField label (Label label value) value where
+  getField :: (Label label value) -> value
+  getField (Label value) = value
+
+-- | Fetch a value from a record, like 'getField', but also keep it wrapped by its label.
+getLabel :: forall label record a. HasField label record a => record -> Label label a
+getLabel rec = rec & getField @label & label @label
+
+-- | A named 2-element tuple. Since the elements are named, you can access them with `.`.
+--
+-- @@
+-- let t2 = T2 (label @"myfield" 'c') (label @"otherfield" True) :: T2 "myfield" Char "otherfield" Bool
+-- in (
+--   t2.myfield :: Char,
+--   t2.otherfield :: Bool
+-- )
+-- @@
+data T2 (l1 :: Symbol) t1 (l2 :: Symbol) t2 = T2 (Label l1 t1) (Label l2 t2)
+
+-- | Access the first field by label
+instance HasField l1 (T2 l1 t1 l2 t2) t1 where
+  getField (T2 t1 _) = getField @l1 t1
+
+-- | Access the second field by label
+instance HasField l2 (T2 l1 t1 l2 t2) t2 where
+  getField (T2 _ t2) = getField @l2 t2
+
+-- | A named 3-element tuple. Since the elements are named, you can access them with `.`. See 'T2' for an example.
+data T3 (l1 :: Symbol) t1 (l2 :: Symbol) t2 (l3 :: Symbol) t3 = T3 (Label l1 t1) (Label l2 t2) (Label l3 t3)
+
+-- | Access the first field by label
+instance HasField l1 (T3 l1 t1 l2 t2 l3 t3) t1 where
+  getField (T3 t1 _ _) = getField @l1 t1
+
+-- | Access the second field by label
+instance HasField l2 (T3 l1 t1 l2 t2 l3 t3) t2 where
+  getField (T3 _ t2 _) = getField @l2 t2
+
+-- | Access the third field by label
+instance HasField l3 (T3 l1 t1 l2 t2 l3 t3) t3 where
+  getField (T3 _ _ t3) = getField @l3 t3