Mapping over a type-level list

Question

I have a typeclass set up something like this:

class (KnownSymbol base, KnownSymbol quote) => FooPair base quote where
  pairVal :: Text

instance FooPair "USD" "ZAR" where
  pairVal = "USDZAR"

instance FooPair "EUR" "ZAR" where
  pairVal = "EURZAR"

Now I would like to be able to handle type-level lists of currency pairs as well. I came up with the following approach using primitive recusion over the list:

type Pair base quote = '(base, quote)

class Pairs ps where
  pairVals :: [Text]

instance Pairs '[] where
  pairVals = []

instance (FooPair base quote, Pairs ps) => Pairs (Pair base quote ': ps) where
  pairVals = (pairVal @base @quote : pairVals @ps)

Now I can do like this:

λ> pairVals @'[Pair "USD" "ZAR", Pair "EUR" "ZAR"]
["USDZAR", "EURZAR"]

However, this feels like a lot of work to do what is just map for value-level lists. Is there a type-level equivalent or some other way to shorten this?

Answer 1

It might be a little cleaner to define pairVal and pairVals at the type level using type families, and then separately think about demoting their results back to the value level. The singletons package makes this pretty easy.

Until they add EnableEveryExtension to GHC, you'll need to enable a bunch of them, and add a few imports:

{-# LANGUAGE
    AllowAmbiguousTypes
  , DataKinds
  , GADTs
  , OverloadedStrings
  , ScopedTypeVariables
  , TemplateHaskell
  , TypeApplications
  , TypeFamilies
  , UndecidableInstances
#-}

module Currency where

import Data.Singletons
import Data.Singletons.Prelude
import Data.Singletons.TH
import Data.Text (Text)

Then, you can define type-level versions of pairVal and pairVals using Template Haskell and promote:

promote
  [d|

    pairVal :: Symbol -> Symbol -> Symbol
    pairVal "USD" "ZAR" = "USDZAR"
    pairVal "EUR" "ZAR" = "EURZAR"

    pairVals :: [(Symbol, Symbol)] -> [Symbol]
    pairVals = map (uncurry pairVal)

   |]

This already makes available the type-level PairVals function, so in GHCi, we can do:

λ> :set -XDataKinds
λ> :kind! PairVals '[ '("USD","ZAR"), '("EUR","ZAR") ]
PairVals '[ '("USD","ZAR"), '("EUR","ZAR") ] :: [Symbol]
= '["USDZAR", "EURZAR"]

If you want to get value-level results from these functions, like your original pairVal and pairVals functions, you can use the demote function provided by the singletons infrastructure. For example, the following works fine:

λ> :set -XTypeApplications
λ> demote @(PairVal "USD" "ZAR")
"USDZAR"
λ> demote @(PairVals '[ '("USD","ZAR"), '("EUR","ZAR") ])
["USDZAR","EURZAR"]

If you want, you can write specialized versions of demote like so:

pairVal' :: forall a b p. (p ~ PairVal a b, SingI p) => Text
pairVal' = demote @p

pairVals' :: forall lst ps. (ps ~ PairVals lst, SingI ps) => [Text]
pairVals' = demote @ps

Note that these aren't promoted functions, so they go outside the promote call. Then, then work exactly like your original pairVal and pairVals functions:

λ> pairVal' @"USD" @"ZAR"
"USDZAR"
λ> pairVals' @ '[ '("USD","ZAR"), '("EUR","ZAR") ]
["USDZAR","EURZAR"]

The full code:

{-# LANGUAGE
    AllowAmbiguousTypes
  , DataKinds
  , GADTs
  , OverloadedStrings
  , ScopedTypeVariables
  , TemplateHaskell
  , TypeApplications
  , TypeFamilies
  , UndecidableInstances
#-}

module Currency where

import Data.Singletons
import Data.Singletons.Prelude
import Data.Singletons.TH
import Data.Text (Text)

promote
  [d|

    pairVal :: Symbol -> Symbol -> Symbol
    pairVal "USD" "ZAR" = "USDZAR"
    pairVal "EUR" "ZAR" = "EURZAR"

    pairVals :: [(Symbol, Symbol)] -> [Symbol]
    pairVals = map (uncurry pairVal)

   |]

pairVal' :: forall a b p. (p ~ PairVal a b, SingI p) => Text
pairVal' = demote @p

pairVals' :: forall lst ps. (ps ~ PairVals lst, SingI ps) => [Text]
pairVals' = demote @ps

main :: IO ()
main = do
  print $ pairVal' @"USD" @"ZAR"
  print $ pairVals' @ '[ '("USD","ZAR"), '("EUR","ZAR") ]