FAlgebras

FAlgebra.purs

data Append t = Append t t
derive instance functorAppend :: Functor Append
type Semigroup' r = (append :: V.FProxy Append | r)
newtype Semigroup t = Semigroup (V.VariantF (Semigroup' ()) t)

derive instance functorSemigroup :: Functor Semigroup

_append = SProxy :: SProxy "append"

append :: forall a. Algebra Semigroup a => a -> a -> a
append xs ys = alg (Semigroup $ V.inj _append (Append xs ys))

data Empty t = Empty
derive instance functorEmpty :: Functor Empty
type Monoid' r = (empty :: V.FProxy Empty | Semigroup' + r)
newtype Monoid t = Monoid (V.VariantF (Monoid' ()) t)

derive instance functorMonoid :: Functor Monoid

_empty = SProxy :: SProxy "empty"

empty :: forall a. Algebra Monoid a => a
empty = alg (Monoid $ V.inj _empty Empty)

class Functor f <= Algebra f t where
  alg :: f t -> t

instance algebraSemigroupAdditive :: Semiring a => Algebra Semigroup (Additive a) where
  alg (Semigroup s) = s # V.match 
    { append: \(Append a b) -> N.over2 Additive (+) a b
    }

instance algebraMonoidAdditive :: Semiring a => Algebra Monoid (Additive a) where
  alg (Monoid s) = s # V.match
    { empty: \Empty -> Additive zero
    , append: \(Append a b) -> append a b
    }

instance algebraSemigroupMaybe :: Algebra Semigroup a => Algebra Semigroup (Maybe a) where
  alg (Semigroup s) = s # V.match
    { append: \(Append x y) -> case x, y of
      Nothing, b -> b
      a, Nothing -> a
      Just a, Just b -> Just (append a b)
    }

instance algebraMonoidMaybe :: (Algebra Semigroup a, Algebra Monoid a) => Algebra Monoid (Maybe a) where
  alg (Monoid s) = s # V.match
    { empty: \Empty -> Nothing
    , append: \(Append a b) -> append a b
    }

main :: Effect Unit
main = do
  logShow $ Just (Additive 10) `append` Just (Additive 20)
  logShow $ empty :: (Maybe (Additive Int))