Wear.hs

{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}
module Barbies.Internal.Wear
  ( Wear, Bare, Covered, WearTwo
  )

where

import GHC.TypeLits (ErrorMessage (..), TypeError)
import Data.Generics.GenericN (Param)

data Bare
data Covered

-- | The 'Wear' type-function allows one to define a Barbie-type as
--
-- @
-- data B t f
--   = B { f1 :: 'Wear' t f 'Int'
--       , f2 :: 'Wear' t f 'Bool'
--       }
-- @
--
-- This gives rise to two rather different types:
--
--   * @B 'Covered' f@ is a normal Barbie-type, in the sense that
--     @f1 :: B 'Covered' f -> f 'Int'@, etc.
--
--   * @B 'Bare' f@, on the other hand, is a normal record with
--     no functor around the type:
--
-- @
-- B { f1 :: 5, f2 = 'True' } :: B 'Bare' f
-- @
type family Wear t f a where
  Wear Bare        f a = a
  Wear Covered     f a = f a
  Wear (Param _ t) f a = Wear t f a
  Wear t       _ _ = TypeError (     'Text "`Wear` should only be used with "
                               ':<>: 'Text "`Bare` or `Covered`."
                               ':$$: 'Text "`" ':<>: 'ShowType t ':<>: 'Text "`"
                               ':<>: 'Text " is not allowed in this context."
                               )

-- | Like the `Wear` family, but with two wrappers @f@ and @g@ instead of one.
-- This is useful if you have a data-type where @f@ is parametric but @g@ is
-- not, consider this:
--
-- @
-- data T t f =
--   T { f1 :: 'Wear'    t f [Bool]
--     , f2 :: 'Wear'    t f (Sum Int)
--     , f3 :: 'WearTwo' t f Sum Int
--     , f4 :: 'WearTwo' t f Max Int
--     }
-- @
--
-- with @x :: T Covered Option@ we would have
--
-- @
-- f1 x :: IO (Option [Bool])
-- f2 x :: IO (Option (Sum Int))
-- f3 x :: IO (Option (Sum Int))
-- f4 x :: IO (Option (Max Int))
-- @
--
-- and with @y :: T Bare Identity@ we would have
--
-- @
-- f1 y :: Int
-- f2 y :: Sum Int
-- f3 y :: Int
-- f4 y :: Int
-- @
--
-- Note how @(Option (Sum Int))@ (or @Max@) has a nice Semigroup instance that
-- we can use to merge two (covered) barbies,
-- while `WearTwo` removes the wrapper for the bare barbie.
type family WearTwo t f g a where
  WearTwo Bare        f g a = a
  WearTwo Covered     f g a = f (g a)
  WearTwo (Param _ t) f g a = WearTwo t f g a
  WearTwo t           _ _ _ =
    TypeError (     'Text "`WearTwo` should only be used with "
              ':<>: 'Text "`Bare` or `Covered`."
              ':$$: 'Text "`" ':<>: 'ShowType t ':<>: 'Text "`"
              ':<>: 'Text " is not allowed in this context."
              )