Skip to content

Instantly share code, notes, and snippets.

@jacobstanley

jacobstanley/dissect-reassoc.hs

Last active March 12, 2016 02:39
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save jacobstanley/5de10b6ca6482d478f4d to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save jacobstanley/5de10b6ca6482d478f4d to your computer and use it in GitHub Desktop.
Download ZIP
Generic deconstruction of product types to tuples
Raw
dissect-reassoc.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module DissectReassoc where
import Data.Proxy
import GHC.Generics
------------------------------------------------------------------------
data RC = RC1 | RC2 | RC3
type family RCase a where
RCase (x, (y, z)) =
RC1
RCase (x, y) =
RC2
RCase x =
RC3
type family ReassocTy a where
ReassocTy (x, (y, z)) =
ReassocTy ((x, y), z) -- UndecidableInstances
ReassocTy (x, y) =
(x, 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)
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) ~ (x, y) => Reassoc' RC2 (x, y) where
reassoc' _ (x, y) =
(x, y)
-- Case 3
instance ReassocTy x ~ x => Reassoc' RC3 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 (K1 i c) where
type GDissected (K1 i c) =
c
gdissect (K1 x) =
x
------------------------------------------------------------------------
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
Raw
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment