Haskell: Helpers to write Generic instance manually

helpers-to-write-generic-instance-manually.hs

#!/usr/bin/env stack
-- stack script --resolver=lts-13.27 --ghc-options -Wincomplete-patterns
{-# LANGUAGE GADTs, DataKinds, TypeFamilies, TypeOperators #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances, DeriveGeneric #-}

import GHC.Generics
import GHC.TypeLits


type family MetaDataOf (typeRep :: * -> *) (typeName :: Symbol) :: Meta where
  MetaDataOf (D1 ('MetaData _ module' package isNewType) _) typeName =
    'MetaData typeName module' package isNewType

type ProtoDatatype (proto :: * -> *) (name :: Symbol) (constructors :: [* -> *])
   = D1 (MetaDataOf proto name) (ProtoDatatypeC constructors)

type family ProtoDatatypeC (constructors :: [* -> *]) :: * -> * where
  ProtoDatatypeC '[x] = x
  ProtoDatatypeC (x ': xs) = x :+: ProtoDatatypeC xs

type EmptyConstructor (name :: Symbol) = C1 ('MetaCons name 'PrefixI 'False) U1

type RecordConstructor (name :: Symbol) (fields :: [(Symbol, *)])
   = C1 ('MetaCons name 'PrefixI 'True) (RecordConstructorF fields)

type family RecordConstructorF (fields :: [(Symbol, *)]) :: * -> * where
  RecordConstructorF '[ '(name, t) ] =
    S1 ( 'MetaSel ('Just name)
                  'NoSourceUnpackedness
                  'NoSourceStrictness
                  'DecidedLazy
       ) (Rec0 t)

  RecordConstructorF (x ': xs) =
    RecordConstructorF '[x] :*: RecordConstructorF xs


data Scenario = ScenarioA | ScenarioB deriving Generic


data Foo (s :: Scenario) where
  ConstructorBoth  :: { foo :: Int,  bar :: String } -> Foo s
  ConstructorOnlyA :: { baz :: Int,  bzz :: Bool   } -> Foo 'ScenarioA
  ConstructorOnlyB :: { zzz :: Bool, xxx :: String } -> Foo 'ScenarioB

instance Generic (Foo 'ScenarioA) where
  type Rep (Foo 'ScenarioA) =
    ProtoDatatype (Rep Scenario) "Foo"
      '[ RecordConstructor "ConstructorBoth"
           '[ '("foo", Int)
            , '("bar", String)
            ]
       , RecordConstructor "ConstructorOnlyA"
           '[ '("baz", Int)
            , '("bzz", Bool)
            ]
       ]

  from (ConstructorBoth  a b) = M1 $ L1 $ M1 $ M1 (K1 a) :*: M1 (K1 b)
  from (ConstructorOnlyA a b) = M1 $ R1 $ M1 $ M1 (K1 a) :*: M1 (K1 b)

  to (M1 (L1 (M1 (M1 (K1 a) :*: M1 (K1 b))))) = ConstructorBoth  a b
  to (M1 (R1 (M1 (M1 (K1 a) :*: M1 (K1 b))))) = ConstructorOnlyA a b

instance Generic (Foo 'ScenarioB) where
  type Rep (Foo 'ScenarioB) =
    ProtoDatatype (Rep Scenario) "Foo"
      '[ RecordConstructor "ConstructorBoth"
           '[ '("foo", Int)
            , '("bar", String)
            ]
       , RecordConstructor "ConstructorOnlyB"
           '[ '("zzz", Bool)
            , '("xxx", String)
            ]
       ]

  from (ConstructorBoth  a b) = M1 $ L1 $ M1 $ M1 (K1 a) :*: M1 (K1 b)
  from (ConstructorOnlyB a b) = M1 $ R1 $ M1 $ M1 (K1 a) :*: M1 (K1 b)

  to (M1 (L1 (M1 (M1 (K1 a) :*: M1 (K1 b))))) = ConstructorBoth  a b
  to (M1 (R1 (M1 (M1 (K1 a) :*: M1 (K1 b))))) = ConstructorOnlyB a b


main :: IO ()
main = pure ()