Metamorphing types in Haskell

metamorph.hs

{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE AllowAmbiguousTypes    #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE TypeInType             #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances          #-}

module Metamorph where

import Data.Kind
import Data.Proxy
import GHC.TypeLits

-- | Datatype that links a 'Symbol' (the key)  to a 'Type' (the value)
data NType :: Type where
  (:=) :: Symbol -> Type -> NType

class In ts rel where
  pick :: ts -> Val rel

-- class In' ts rel where
  -- pick :: ts -> Val' rel

newtype Val (rel :: NType) = Val
  { unVal :: forall sym ty. (rel ~ (sym ':= ty)) => ty }

newtype Wrapped (sym :: Symbol) (ty :: Type) = Wrapped { unWrap :: ty }

pull :: forall sym ty rel ts. (rel ~ (sym ':= ty), In ts rel) => ts -> ty
pull = unVal @(sym ':= ty) . pick

class HasVal ts ty where
  pickVal :: ts -> ty

instance (In ts rel, rel ~ (sym ':= ty)) => HasVal ts ty where
  pickVal = pull @sym

pullAny :: HasVal ts ty => ts -> ty
pullAny = pickVal


class Morph ty ty' where
  morph :: ty -> ty'


-- This is easy, but not what we want to achieve

instance Morph a a where
  morph = id

instance HasVal ts ty => Morph ts ty where
  morph = pullAny

instance (HasVal ts ty1, HasVal ts ty2) => Morph ts (ty1, ty2) where
  morph src = (pullAny src, pullAny src)

-- HList stuff

data HList :: [NType] -> Type where
  HNil  :: HList '[]
  HCons :: a -> HList ts -> HList ((n ':= a) ': ts)

instance {-# OVERLAPPING #-} (sym ~ sy) => In (HList (sym ':= ty ': ts)) (sy ':= ty) where
  pick (HCons x _) = Val x

instance (In (HList ts) (sym ':= ty)) => In (HList (t ': ts)) (sym ':= ty) where
  pick (HCons _ more) = pick more


-- So this works with HList, can we generalize?
instance (HasVal ts ty, Morph ts (HList tys)) => Morph ts (HList (n ':= ty ': tys)) where
  morph src = HCons (pullAny src) (morph src)

-- OLD STUFF

class Contains (ts :: [NType]) (sym :: Symbol) (n :: Type) where
  extract :: HList ts -> Wrapped sym n

instance (Contains ts sym ty) => Contains (t ': ts) sym ty where
  extract (HCons _ more) = extract more

instance {-# OVERLAPPING #-} (sym ~ sy) => Contains ( sym ':= ty ': ts) sy ty where
  extract (HCons x _) = Wrapped x

proxied :: Proxy (sym :: Symbol) -> HList ts -> r -> HList ( sym ':= r ': ts)
proxied _ l v = HCons v l

pick' :: forall sym n ts. Contains ts sym n => HList ts -> n
pick' = unWrap @sym . extract

pickProxy :: forall sym n ts. Contains ts sym n => Proxy sym -> HList ts -> n
pickProxy _ = unWrap @sym . extract

class Metamorph ts a where
  metamorph :: HList ts -> a

instance (Contains ts sym ty) => Metamorph ts ty where
  metamorph = pick' @sym

instance {-# OVERLAPPING #-}
         ( ts1 ~ ts2
         , Contains ts1 sym1 ty1
         , Contains ts2 sym2 ty2)
         => Metamorph ts1 (ty1, ty2) where
  metamorph hlist = (pick' @sym1 hlist, pick' @sym2 hlist)

instance {-# OVERLAPPING #-}
         ( ts1 ~ ts2
         , ts1 ~ ts3
         , Contains ts1 sym1 ty1
         , Contains ts2 sym2 ty2
         , Contains ts3 sym3 ty3 )
         => Metamorph ts1 (ty1, ty2, ty3) where
  metamorph hlist = (pick' @sym1 hlist, pick' @sym2 hlist, pick' @sym3 hlist)