Product.hs

{-# language DataKinds              #-}
{-# language DerivingStrategies     #-}
{-# language DeriveFunctor          #-}
{-# language FlexibleContexts       #-}
{-# language FlexibleInstances      #-}
{-# language FunctionalDependencies #-}
{-# language GADTs                  #-}
{-# language KindSignatures         #-}
{-# language MultiParamTypeClasses  #-}
{-# language ScopedTypeVariables    #-}
{-# language TypeApplications       #-}
{-# language TypeOperators          #-}
{-# language UndecidableInstances   #-}

module Product where

import Data.Proxy   (Proxy (..))
import GHC.TypeLits (Symbol, KnownSymbol (..), symbolVal)

-- | A heterogeneous list, the `<...>`.
data Product xs where
  (:>) :: x -> Product xs -> Product (x : xs)
  Nil  :: Product '[]

infixr 1 :>

-- | The `foo` part in `foo: x`.
newtype (tag :: Symbol) :- a = Tag { unTag :: a }
  deriving stock Functor

-- | Map specific element inside `Product`.
class                         MapElem a b s t | s -> a, t -> b where mapElem :: (a -> b) -> Product s -> Product t
instance                      MapElem a b (a : xs) (b : xs)    where mapElem f (x :> xs) = f x :> xs
instance MapElem a b xs ys => MapElem a b (c : xs) (c : ys)    where mapElem f (x :> xs) = x   :> mapElem f xs

-- | Map over the heterogeneous list.
mapTag
  :: forall tag a b s t
  .  MapElem (tag :- a) (tag :- b) s t
  => (a -> b)
  -> Product s
  -> Product t
mapTag = mapElem . fmap

-- | Example, input.
--
--   Is printed as {foo: "foo", bar: 1323, flag: True}
--
x :: Product ["foo" :- String, "bar" :- Int, "flag" :- Bool]
x = Tag "foo" :> Tag 1323 :> Tag True :> Nil

-- | Example, output.
--
--   Is printed as {foo: "foo", bar: 1323.0, flag: True}
--
y :: Product ["foo" :- String, "bar" :- Float, "flag" :- Bool]
y = mapTag @"bar" fromIntegral x

---- Pretty-printer -----------------------------------------------------------

instance ShowProduct xs => Show (Product xs) where
  show xs = "{" ++ showProduct xs ++ "}"

class ShowProduct xs where
  showProduct :: Product xs -> String

instance ShowProduct '[] where
  showProduct _ = ""

instance {-# overlaps #-} Show x => ShowProduct '[x] where
  showProduct (x :> _) = show x

instance (Show x, ShowProduct xs) => ShowProduct (x : xs) where
  showProduct (x :> xs) = show x ++ ", " ++ showProduct xs

-- | Show the value with the tag.
instance (Show a, KnownSymbol tag) => Show (tag :- a) where
  show (Tag a) = symbolVal (Proxy :: Proxy tag) ++ ": " ++ show a