TypeClassesAreApparentlyInterfaces1.hs

{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE UndecidableInstances  #-}

module TypeClassesAreApparentlyInterfaces1 where

import Control.Applicative
import Control.Monad.Free
import Control.Monad




newtype Subsystem constr a = Subsystem
    { unSubsystem :: forall m. constr m => m a
    }

instance (forall f. constr f => Functor f) => Functor (Subsystem constr) where
    fmap f (Subsystem a) = Subsystem $ fmap f a
    x <$ Subsystem a = Subsystem $ x <$ a

instance (forall f. constr f => Applicative f) => Applicative (Subsystem constr) where
    pure x = Subsystem $ pure x
    Subsystem f <*> Subsystem a = Subsystem $ f <*> a
    Subsystem f <* Subsystem a = Subsystem $ f <* a
    Subsystem f *> Subsystem a = Subsystem $ f *> a
    liftA2 f (Subsystem a) (Subsystem b) = Subsystem $ liftA2 f a b

instance (forall m. constr m => Monad m) => Monad (Subsystem constr) where
    return = pure
    Subsystem a >>= f = Subsystem $ a >>= unSubsystem . f
    a >> b = a *> b









data BreadType = Baguette | Toast
  deriving (Show, Eq, Ord)

data Component
  = Bread BreadType
  | Tomato
  | Salt
  | Cheese
  deriving (Show, Eq, Ord)


data SandwichBody = SandwichBody BreadType [Component]
  deriving (Show, Eq, Ord)

data Sandwich = Sandwich BreadType (Maybe BreadType) [Component]
  deriving (Show, Eq, Ord)

class Monad m => CSandwichRecipe m where
  startNewSandwich :: BreadType -> Component -> m SandwichBody
  addComponent :: Component -> SandwichBody -> m SandwichBody
  finishSandwich :: Maybe BreadType -> SandwichBody -> m Sandwich

type SandwichRecipe = Subsystem CSandwichRecipe

instance (forall m. constr m => CSandwichRecipe m) => CSandwichRecipe (Subsystem constr) where
  startNewSandwich x y = Subsystem $ startNewSandwich x y
  addComponent x y = Subsystem $ addComponent x y
  finishSandwich x y = Subsystem $ finishSandwich x y



data Crust = ThickCrust | ThinCrust
  deriving (Show, Eq, Ord)
data PizzaComponent = Salami | AmericanCheese
  deriving (Show, Eq, Ord)
data Pizza = Pizza Crust [PizzaComponent]
  deriving (Show, Eq, Ord)

class Monad m => CPizzaRecipe m where
  makeCirclePizza :: Crust -> [PizzaComponent] -> m Pizza
  makeSquarePizza :: Crust -> [PizzaComponent] -> m Pizza

type PizzaRecipe = Subsystem CPizzaRecipe

instance (forall m. constr m => CPizzaRecipe m) => CPizzaRecipe (Subsystem constr) where
  makeCirclePizza x y = Subsystem $ makeCirclePizza x y
  makeSquarePizza x y = Subsystem $ makeSquarePizza x y



data Meal
 = PreparedPizza Pizza
 | PreparedSandwich Sandwich
 deriving (Show, Eq, Ord)


class (CPizzaRecipe m, CSandwichRecipe m) => CCookingMachine m where
  makeRandomPizzaRecipe :: m (PizzaRecipe Pizza)

type CookingMachine = Subsystem CCookingMachine

instance (forall m. constr m => CCookingMachine m) => CCookingMachine (Subsystem constr) where
  makeRandomPizzaRecipe = Subsystem makeRandomPizzaRecipe













makePizza :: PizzaRecipe Pizza -> CookingMachine Meal
makePizza receipe = undefined

makeSandwich :: SandwichRecipe Sandwich -> CookingMachine Meal
makeSandwich receipe = undefined

myPizza :: PizzaRecipe Pizza
myPizza = undefined

mySandwich :: SandwichRecipe Sandwich
mySandwich = do
  body1 <- startNewSandwich Toast Tomato
  body2 <- addComponent Cheese body1
  body3 <- addComponent Salt body2
  finishSandwich Nothing body3

sampleCookingMachine :: CookingMachine [Meal]
sampleCookingMachine = do
 pizza <- makePizza myPizza

 rndPizzaRecipe <- makeRandomPizzaRecipe
 rndPizza <- makePizza rndPizzaRecipe
 pure [pizza, rndPizza]

TypeClassesAreApparentlyInterfaces2.hs

{-# LANGUAGE RankNTypes            #-}

module TypeClassesAreApparentlyInterfaces2 where

import Control.Applicative
import Control.Monad.Free
import Control.Monad









data BreadType = Baguette | Toast
  deriving (Show, Eq, Ord)

data Component
  = Bread BreadType
  | Tomato
  | Salt
  | Cheese
  deriving (Show, Eq, Ord)


data SandwichBody = SandwichBody BreadType [Component]
  deriving (Show, Eq, Ord)

data Sandwich = Sandwich BreadType (Maybe BreadType) [Component]
  deriving (Show, Eq, Ord)

class Monad m => CSandwichRecipe m where
  startNewSandwich :: BreadType -> Component -> m SandwichBody
  addComponent :: Component -> SandwichBody -> m SandwichBody
  finishSandwich :: Maybe BreadType -> SandwichBody -> m Sandwich



data Crust = ThickCrust | ThinCrust
  deriving (Show, Eq, Ord)
data PizzaComponent = Salami | AmericanCheese
  deriving (Show, Eq, Ord)
data Pizza = Pizza Crust [PizzaComponent]
  deriving (Show, Eq, Ord)

class Monad m => CPizzaRecipe m where
  makeCirclePizza :: Crust -> [PizzaComponent] -> m Pizza
  makeSquarePizza :: Crust -> [PizzaComponent] -> m Pizza



data Meal
 = PreparedPizza Pizza
 | PreparedSandwich Sandwich
 deriving (Show, Eq, Ord)


class (CPizzaRecipe m, CSandwichRecipe m) => CCookingMachine m where
  withRandomPizzaRecipe :: ((forall p. CPizzaRecipe p => p Pizza) -> m b) -> m b












makePizza :: CCookingMachine m => (forall p. CPizzaRecipe p => p Pizza) -> m Meal
makePizza receipe = undefined

makeSandwich :: CCookingMachine m => (forall p. CSandwichRecipe p => p Sandwich) -> m Meal
makeSandwich receipe = undefined

myPizza :: CPizzaRecipe p => p Pizza
myPizza = undefined

mySandwich :: CSandwichRecipe m => m Sandwich
mySandwich = do
  body1 <- startNewSandwich Toast Tomato
  body2 <- addComponent Cheese body1
  body3 <- addComponent Salt body2
  finishSandwich Nothing body3

sampleCookingMachine :: CCookingMachine m => m [Meal]
sampleCookingMachine = do
 pizza <- makePizza myPizza

 withRandomPizzaRecipe $ \rndPizzaRecipe -> do
   rndPizza <- makePizza rndPizzaRecipe
   pure [pizza, rndPizza]