Generic deconstruction of product types to tuples

dissect-reassoc.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module X.Text.Show where

import           Data.Proxy
import           GHC.Generics

------------------------------------------------------------------------

type family ReassocTy a where
  ReassocTy (x, (y, z)) =
    ReassocTy ((x, y), z) -- UndecidableInstances
  ReassocTy (x, y) =
    (ReassocTy x, ReassocTy y)
  ReassocTy (Either x y) =
    Either (ReassocTy x) (ReassocTy y)
  ReassocTy x =
    x

class Reassoc a where
  reassoc :: a -> ReassocTy a

instance (Reassoc' rcase a, RCase a ~ rcase) => Reassoc a where
  reassoc =
    reassoc' (Proxy :: Proxy rcase)

------------------------------------------------------------------------

data RC = RC1 | RC2 | RC3 | RC4

type family RCase a where
  RCase (x, (y, z)) =
    RC1
  RCase (x, y) =
    RC2
  RCase (Either x y) =
    RC3
  RCase x =
    RC4

class Reassoc' (rcase :: RC) a where
  reassoc' :: Proxy rcase -> a -> ReassocTy a

-- Case 1
instance Reassoc' (RCase ((x, y), z)) ((x, y), z) => Reassoc' RC1 (x, (y, z)) where
  reassoc' _ (x, (y, z)) =
    reassoc'
      (Proxy :: Proxy (RCase ((x, y), z)))
      ((x, y), z)

-- Case 2
instance
  ( ReassocTy (x, y) ~ (ReassocTy x, ReassocTy y)
  , Reassoc' (RCase x) x
  , Reassoc' (RCase y) y )=> Reassoc' RC2 (x, y) where
  reassoc' _ (x, y) =
    ( reassoc' (Proxy :: Proxy (RCase x)) x
    , reassoc' (Proxy :: Proxy (RCase y)) y )

-- Case 3
instance
  ( ReassocTy (Either x y) ~ (Either (ReassocTy x) (ReassocTy y))
  , Reassoc' (RCase x) x
  , Reassoc' (RCase y) y ) => Reassoc' RC3 (Either x y) where
  reassoc' _ = \case
    Left x ->
      Left $ reassoc' (Proxy :: Proxy (RCase x)) x
    Right y ->
      Right $ reassoc' (Proxy :: Proxy (RCase y)) y

-- Case 4
instance ReassocTy x ~ x => Reassoc' RC4 x where
  reassoc' _ x =
    x

------------------------------------------------------------------------

class GDissect f where
  type GDissected f
  gdissect :: f p -> (GDissected f)

instance GDissect f => GDissect (M1 i c f) where
  type GDissected (M1 i c f) =
    GDissected f
  gdissect (M1 x) =
    gdissect x

instance (GDissect f, GDissect g) => GDissect (f :*: g) where
  type GDissected (f :*: g) =
    (GDissected f, GDissected g)
  gdissect (x :*: y) =
    (gdissect x, gdissect y)

instance (GDissect f, GDissect g) => GDissect (f :+: g) where
  type GDissected (f :+: g) =
    Either (GDissected f) (GDissected g)
  gdissect = \case
    L1 x ->
      Left $ gdissect x
    R1 y ->
      Right $ gdissect y

instance GDissect (K1 i c) where
  type GDissected (K1 i c) =
    c
  gdissect (K1 x) =
    x

instance GDissect U1 where
  type GDissected U1 =
    ()
  gdissect U1 =
    ()

------------------------------------------------------------------------

type family Dissected a where
  Dissected a = ReassocTy (GDissected (Rep a))

dissect :: (Generic a, GDissect (Rep a), Reassoc (GDissected (Rep a))) => a -> Dissected a
dissect =
  reassoc . gdissect . from

------------------------------------------------------------------------


--
-- Generic type of Foo:
--
-- M1 D D1Foo
--   (M1 C C1_0Foo
--     (M1 S NoSelector (Rec0 Int) :*:
--     (M1 S NoSelector (Rec0 Int) :*:
--      M1 S NoSelector (Rec0 String))))
--
data Foo = Foo Int Int Int String
  deriving (Generic)

foo :: Foo -> (((Int, Int), Int), String)
foo =
  dissect

data BBQ =
    Bar Int
  | Baz Int Double String
  | Quux
    deriving (Generic)

bbq :: BBQ -> Either Int (Either ((Int, Double), String) ())
bbq =
  dissect

dissect.hs

{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
module Dissect where

import GHC.Generics

class GDissect f where
  type GDissected f
  gdissect :: f p -> GDissected f

instance GDissect f => GDissect (M1 i c f) where
  type GDissected (M1 i c f) =
    GDissected f
  gdissect (M1 x) =
    gdissect x

instance (GDissect f, GDissect g) => GDissect (f :*: g) where
  type GDissected (f :*: g) =
    (GDissected f, GDissected g)
  gdissect (x :*: y) =
    (gdissect x, gdissect y)

instance GDissect (K1 i c) where
  type GDissected (K1 i c) =
    c
  gdissect (K1 x) =
    x


--
-- Generic type of Foo:
--
-- M1 D D1Foo
--   (M1 C C1_0Foo
--     (M1 S NoSelector (Rec0 Int) :*:
--     (M1 S NoSelector (Rec0 Int) :*:
--      M1 S NoSelector (Rec0 String))))
--
data Foo = Foo Int Int String
  deriving (Generic)

foo :: Foo -> (Int, (Int, String))
foo = gdissect . from