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

Revisions

  1. jacobstanley revised this gist Mar 12, 2016. 1 changed file with 62 additions and 15 deletions.
    77 changes: 62 additions & 15 deletions dissect-reassoc.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -2,33 +2,26 @@
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TypeFamilies #-}
    {-# LANGUAGE TypeOperators #-}
    {-# LANGUAGE UndecidableInstances #-}
    module DissectReassoc where
    module X.Text.Show 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, ReassocTy y)
    ReassocTy (Either x y) =
    Either (ReassocTy x) (ReassocTy y)
    ReassocTy x =
    x

    @@ -39,6 +32,20 @@ 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

    @@ -50,12 +57,27 @@ instance Reassoc' (RCase ((x, y), z)) ((x, y), z) => Reassoc' RC1 (x, (y, z)) wh
    ((x, y), z)

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

    -- Case 3
    instance ReassocTy x ~ x => Reassoc' RC3 x where
    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

    @@ -77,12 +99,27 @@ instance (GDissect f, GDissect g) => GDissect (f :*: g) where
    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
    @@ -109,4 +146,14 @@ data Foo = Foo Int Int Int String

    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
  2. jacobstanley revised this gist Mar 12, 2016. 1 changed file with 112 additions and 0 deletions.
    112 changes: 112 additions & 0 deletions dissect-reassoc.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,112 @@
    {-# 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
  3. jacobstanley created this gist Mar 11, 2016.
    44 changes: 44 additions & 0 deletions dissect.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,44 @@
    {-# 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