Code accompanying https://harry.garrood.me/blog/write-your-own-generics

Main.purs

module Main where

import Prelude

import Control.Alt ((<|>))
import Data.Array as Array
import Data.Generic.Rep as G
import Data.Generic.Rep.Show (genericShow)
import Data.Int as Int
import Data.Maybe (Maybe(..))
import Data.Symbol (class IsSymbol, reflectSymbol, SProxy(..))
import Effect (Effect)
import Effect.Console (log)
import Partial.Unsafe (unsafeCrashWith)
import TryPureScript (render, withConsole)

-- If you want to run this code outside Try PureScript, remove the
-- TryPureScript import, as well as the `render =<< withConsole`.
main :: Effect Unit
main = render =<< withConsole do
  log "### Just using Sum and Product ###"
  main1
  log ""
  log "### Making use of Generic metadata ###"
  main2

data Sum a b = Inl a | Inr b
data Product a b = Product a b

-- Type operators for Sum and Product
infixl 6 type Sum as :+:
infixl 7 type Product as :*:

-- Operator for the Product data constructor
infixl 7 Product as :*:

type MaybeRep a = Unit :+: a

repFromMaybe :: forall a. Maybe a -> MaybeRep a
repFromMaybe = case _ of
  Nothing -> Inl unit
  Just x -> Inr x

repToMaybe :: forall a. MaybeRep a -> Maybe a
repToMaybe = case _ of
  Inl _ -> Nothing
  Inr x -> Just x

-- This should really be a sum type but I can't be bothered to write all the
-- constructors out and define conversions to/from String
newtype PokémonType = PokémonType String

-- Auxiliary newtypes for clarity
newtype Species = Species String
newtype Level = Level Int

-- | Fields are Species, level, primary type, secondary type (if any)
data Pokémon = Pokémon Species Level PokémonType (Maybe PokémonType)

-- Some example values
pikachu :: Pokémon
pikachu = Pokémon (Species "Pikachu") (Level 50) (PokémonType "Electric") Nothing

dewgong :: Pokémon
dewgong = Pokémon (Species "Dewgong") (Level 62) (PokémonType "Water") (Just (PokémonType "Ice"))

type PokémonRep = Species :*: Level :*: PokémonType :*: Maybe PokémonType

repFromPokémon :: Pokémon -> PokémonRep
repFromPokémon (Pokémon species level primaryType secondaryType) =
  species :*: level :*: primaryType :*: secondaryType

repToPokémon :: PokémonRep -> Pokémon
repToPokémon (species :*: level :*: primaryType :*: secondaryType) =
  Pokémon species level primaryType secondaryType

data PoisonSeverity = NormalPoison | BadPoison

data PokémonStatus
  = Asleep Int
  | Poisoned PoisonSeverity Int
  | Paralyzed

type PokémonStatusRep =
  Int -- Asleep
  :+: (PoisonSeverity :*: Int) -- Poisoned
  :+: Unit -- Paralyzed

repFromPokémonStatus :: PokémonStatus -> PokémonStatusRep
repFromPokémonStatus = case _ of
  Asleep counter -> Inl (Inl counter)
  Poisoned severity counter -> Inl (Inr (severity :*: counter))
  Paralyzed -> Inr unit

repToPokémonStatus :: PokémonStatusRep -> PokémonStatus
repToPokémonStatus = case _ of
  Inl (Inl counter) -> Asleep counter
  Inl (Inr (severity :*: counter)) -> Poisoned severity counter
  Inr _ -> Paralyzed

class Generic a rep | a -> rep where
  to :: rep -> a
  from :: a -> rep

-- Type synonym instances would be really handy here, but sadly we don't have
-- them just yet

-- Generic (Maybe a) (MaybeRep a)
instance genericMaybe :: Generic (Maybe a) (Unit :+: a) where
  to = repToMaybe
  from = repFromMaybe

-- Generic Pokémon PokémonRep
instance genericPokémon :: Generic Pokémon (Species :*: Level :*: PokémonType :*: Maybe PokémonType) where
  to = repToPokémon
  from = repFromPokémon

-- Generic PokémonStatus PokémonStatusRep
instance genericPokémonStatus :: Generic PokémonStatus (Int :+: (PoisonSeverity :*: Int) :+: Unit) where
  to = repToPokémonStatus
  from = repFromPokémonStatus

data Tree a = Tree a (Array (Tree a))

class TreeEncode a where
  treeEncode :: a -> Tree String

class TreeDecode a where
  treeDecode :: Tree String -> Maybe a

instance treeEncodeString :: TreeEncode String where
  treeEncode x = Tree x []

instance treeEncodeInt :: TreeEncode Int where
  treeEncode = treeEncode <<< show

instance treeDecodeString :: TreeDecode String where
  treeDecode = case _ of
    Tree s [] -> Just s
    _ -> Nothing

instance treeDecodeInt :: TreeDecode Int where
  treeDecode = Int.fromString <=< treeDecode

instance treeEncodeUnit :: TreeEncode Unit where
  treeEncode _ = Tree "Unit" []

instance treeDecodeUnit :: TreeDecode Unit where
  treeDecode = case _ of
    Tree "Unit" [] -> Just unit
    _ -> Nothing

instance treeEncodeMaybe :: TreeEncode a => TreeEncode (Maybe a) where
  treeEncode = case _ of
    Just a -> Tree "Just" [treeEncode a]
    Nothing -> Tree "Nothing" []

instance treeDecodeMaybe :: TreeDecode a => TreeDecode (Maybe a) where
  treeDecode = case _ of
    Tree "Just" [a] -> Just <$> treeDecode a
    Tree "Nothing" [] -> Just Nothing
    _ -> Nothing

derive newtype instance treeEncodeSpecies :: TreeEncode Species
derive newtype instance treeDecodeSpecies :: TreeDecode Species

derive newtype instance treeEncodeLevel :: TreeEncode Level
derive newtype instance treeDecodeLevel :: TreeDecode Level

derive newtype instance treeEncodePokémonType :: TreeEncode PokémonType
derive newtype instance treeDecodePokémonType :: TreeDecode PokémonType

instance treeEncodePoisonSeverity :: TreeEncode PoisonSeverity where
  treeEncode s = treeEncode case s of
    NormalPoison -> "NormalPoison"
    BadPoison -> "BadPoison"

instance treeDecodePoisonSeverity :: TreeDecode PoisonSeverity where
  treeDecode = fromString <=< treeDecode
    where
    fromString = case _ of
      "NormalPoison" -> Just NormalPoison
      "BadPoison" -> Just BadPoison
      _ -> Nothing

instance treeEncodeSum :: (TreeEncode a, TreeEncode b) => TreeEncode (Sum a b) where
  treeEncode = case _ of
    Inl a -> Tree "Sum:Inl" [treeEncode a]
    Inr b -> Tree "Sum:Inr" [treeEncode b]

instance treeDecodeSum :: (TreeDecode a, TreeDecode b) => TreeDecode (Sum a b) where
  treeDecode = case _ of
    Tree "Sum:Inl" [a] -> Inl <$> treeDecode a
    Tree "Sum:Inr" [b] -> Inr <$> treeDecode b
    _ -> Nothing

instance treeEncodeProduct :: (TreeEncode a, TreeEncode b) => TreeEncode (Product a b) where
  treeEncode (Product a b) = Tree "Product" [treeEncode a, treeEncode b]

instance treeDecodeProduct :: (TreeDecode a, TreeDecode b) => TreeDecode (Product a b) where
  treeDecode = case _ of
    Tree "Product" [a, b] -> Product <$> treeDecode a <*> treeDecode b
    _ -> Nothing

genericTreeEncode
  :: forall a rep. Generic a rep => TreeEncode rep => a -> Tree String
genericTreeEncode =
  treeEncode <<< from

genericTreeDecode
  :: forall a rep. Generic a rep => TreeDecode rep => Tree String -> Maybe a
genericTreeDecode =
  map to <<< treeDecode

instance treeEncodePokémon :: TreeEncode Pokémon where
  treeEncode = genericTreeEncode

instance treeDecodePokémon :: TreeDecode Pokémon where
  treeDecode = genericTreeDecode

instance treeEncodePokémonStatus :: TreeEncode PokémonStatus where
  treeEncode = genericTreeEncode

instance treeDecodePokémonStatus :: TreeDecode PokémonStatus where
  treeDecode = genericTreeDecode

main1 :: Effect Unit
main1 = do
  testRoundTrip "pikachu" pikachu
  testRoundTrip "paralyzed" Paralyzed
  testRoundTrip "poisoned" (Poisoned BadPoison 4)

  where
  testRoundTrip ::
    forall a.
    TreeEncode a =>
    TreeDecode a =>
    Eq a =>
    Show a =>
    String -> a -> Effect Unit
  testRoundTrip msg a = do
    log "======"
    log $ "Testing roundtrip: " <> msg
    log $ "Initial value: " <> show a
    log $ "Encoded:       " <> show (treeEncode a)
    let roundTripped = treeDecode (treeEncode a)
    log $ "Round trips successfully? " <> if roundTripped == Just a then "Yes" else "No"

derive instance genericPokémon' :: G.Generic Pokémon _
derive instance genericPokémonStatus' :: G.Generic PokémonStatus _

class TreeEncodeArgs a where
  treeEncodeArgs :: a -> Array (Tree String)

class TreeDecodeArgs a where
  treeDecodeArgs :: Array (Tree String) -> Maybe { result :: a, rest :: Array (Tree String) }

instance treeEncodeArgsNoArguments :: TreeEncodeArgs G.NoArguments where
  treeEncodeArgs _ = []

instance treeEncodeArgsArgument :: TreeEncode a => TreeEncodeArgs (G.Argument a) where
  treeEncodeArgs (G.Argument a) = [treeEncode a]

instance treeEncodeArgsProduct :: (TreeEncodeArgs a, TreeEncodeArgs b) => TreeEncodeArgs (G.Product a b) where
  treeEncodeArgs (G.Product a b) = treeEncodeArgs a <> treeEncodeArgs b

instance treeDecodeArgsNoArguments :: TreeDecodeArgs G.NoArguments where
  treeDecodeArgs = case _ of
    [] -> Just { result: G.NoArguments, rest: [] }
    _ -> Nothing

instance treeDecodeArgsArgument :: TreeDecode a => TreeDecodeArgs (G.Argument a) where
  treeDecodeArgs args = do
    { head, tail: rest } <- Array.uncons args
    result <- G.Argument <$> treeDecode head
    pure { result, rest }

instance treeDecodeArgsProduct :: (TreeDecodeArgs a, TreeDecodeArgs b) => TreeDecodeArgs (G.Product a b) where
  treeDecodeArgs args = do
    { result: a, rest: args1 } <- treeDecodeArgs args
    { result: b, rest: args2 } <- treeDecodeArgs args1
    pure { result: G.Product a b, rest: args2 }

instance treeEncodeSum' :: (TreeEncode a, TreeEncode b) => TreeEncode (G.Sum a b) where
  treeEncode (G.Inl a) = treeEncode a
  treeEncode (G.Inr b) = treeEncode b

instance treeDecodeSum' :: (TreeDecode a, TreeDecode b) => TreeDecode (G.Sum a b) where
  treeDecode t = (G.Inl <$> treeDecode t) <|> (G.Inr <$> treeDecode t)

instance treeEncodeConstructor :: (IsSymbol name, TreeEncodeArgs a) => TreeEncode (G.Constructor name a) where
  treeEncode (G.Constructor a) =
    let
      tag = reflectSymbol (SProxy :: SProxy name)
    in
      Tree tag (treeEncodeArgs a)

instance treeDecodeConstructor :: (IsSymbol name, TreeDecodeArgs a) => TreeDecode (G.Constructor name a) where
  treeDecode (Tree tag args) =
    if tag == reflectSymbol (SProxy :: SProxy name)
      then (G.Constructor <<< _.result) <$> treeDecodeArgs args
      else Nothing

instance treeEncodeNoConstructors :: TreeEncode G.NoConstructors where
  treeEncode _ = unsafeCrashWith "unreachable"

instance treeDecodeNoConstructors :: TreeDecode G.NoConstructors where
  treeDecode _ = Nothing
  
genericTreeEncode'
  :: forall a rep. G.Generic a rep => TreeEncode rep => a -> Tree String
genericTreeEncode' =
  treeEncode <<< G.from

genericTreeDecode'
  :: forall a rep. G.Generic a rep => TreeDecode rep => Tree String -> Maybe a
genericTreeDecode' =
  map G.to <<< treeDecode

main2 :: Effect Unit
main2 = do
  testRoundTrip "pikachu" pikachu
  testRoundTrip "paralyzed" Paralyzed
  testRoundTrip "poisoned" (Poisoned BadPoison 4)

  where
  testRoundTrip ::
    forall a rep.
    G.Generic a rep =>
    TreeEncode rep =>
    TreeDecode rep =>
    Eq a =>
    Show a =>
    String -> a -> Effect Unit
  testRoundTrip msg a = do
    log "======"
    log $ "Testing roundtrip: " <> msg
    log $ "Initial value: " <> show a
    log $ "Encoded:       " <> show (genericTreeEncode' a)
    let roundTripped = genericTreeDecode' (genericTreeEncode' a)
    log $ "Round trips successfully? " <> if roundTripped == Just a then "Yes" else "No"

-- Show and Eq instances
derive instance eqPokémon :: Eq Pokémon
derive instance eqPokémonType :: Eq PokémonType
derive instance eqPokémonStatus :: Eq PokémonStatus
derive instance eqPoisonSeverity :: Eq PoisonSeverity
derive instance eqSpecies :: Eq Species
derive instance eqLevel :: Eq Level

derive instance genericTree :: G.Generic (Tree a) _
derive instance genericSpecies :: G.Generic Species _
derive instance genericLevel :: G.Generic Level _
derive instance genericPokémonType :: G.Generic PokémonType _
derive instance genericPoisonSeverity :: G.Generic PoisonSeverity _

instance showTree :: Show a => Show (Tree a) where
  show x = genericShow x

instance showLevel :: Show Level where
  show = genericShow

instance showSpecies :: Show Species where
  show = genericShow
  
instance showPokémonType :: Show PokémonType where
  show = genericShow
  
instance showPokémon :: Show Pokémon where
  show = genericShow
  
instance showPokémonStatus :: Show PokémonStatus where
  show = genericShow
  
instance showPoisonSeverity :: Show PoisonSeverity where
  show = genericShow