Skip to content

Instantly share code, notes, and snippets.

@hdgarrood
Last active August 15, 2020 14:22
Show Gist options
  • Save hdgarrood/c99f9ebf3bec311d1a5065f3fa4bfaa1 to your computer and use it in GitHub Desktop.
Save hdgarrood/c99f9ebf3bec311d1a5065f3fa4bfaa1 to your computer and use it in GitHub Desktop.
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment