numhask basics

basics.hs

#!/usr/bin/env stack
-- stack --install-ghc runghc --resolver nightly-2018-08-17 -- -Wall -O2

{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RebindableSyntax #-}

module T1 where

import Data.Coerce
import qualified Prelude as P
import Prelude (Double, fromInteger)
import qualified GHC.Generics as P

class Magma a where
  magma :: a -> a -> a

class Magma a => Unital a where
  unit :: a

class Magma a => Associative a

class Magma a => Commutative a

newtype Sum a = Sum a
  deriving (P.Eq, P.Ord, P.Read, P.Show, P.Bounded, P.Generic, P.Generic1,
            P.Functor)

type role Sum representational

instance Magma (Sum Double) where
  magma = coerce ((P.+) @Double)

{-
-- some other ways

instance Magma (Sum Double) where
  magma = coerceTA (P.+)

instance Magma (Sum Double) where
  magma = coerce @(Double -> Double -> Double) @(Sum Double -> Sum Double -> Sum Double) (P.+)

-}

instance Unital (Sum Double) where
  unit = coerce (0 :: P.Double)

instance Associative (Sum Double)
instance Commutative (Sum Double)

-- The `Additive` class/instance is not much more than a better version of
-- type Additive a = (Unital (Sum a), Associative (Sum a), Commutative (Sum a))
-- It requires UndecidableInstances eg
-- The constraint ‘Unital (Sum a)’ is no smaller than the instance head ‘Additive a’ (Use UndecidableInstances to permit this)
-- See https://www.reddit.com/r/haskell/comments/5zjwym/when_is_undecidableinstances_okay_to_use/ for why this is benign.
class (Unital (Sum a), Associative (Sum a), Commutative (Sum a))
  => Additive a where

  sum :: (P.Foldable f) => f a -> a
  sum = P.foldr (+) zero

  infixl 6 +
  (+) :: a -> a -> a
  (+) = coerceFA magma

  zero :: a
  zero = let (Sum a) = unit in a

instance (Unital (Sum a), Associative (Sum a), Commutative (Sum a)) => Additive a

-- Outside the class, ghc suggests that `Additive a` constraints should be replaced by `Unital (Sum a), Associative (Sum a), Commutative (Sum a)`
-- -fsimplifiable-constraints
-- sum :: (Additive a, P.Foldable f) => f a -> a
sum' :: (Unital (Sum a), Associative (Sum a), Commutative (Sum a), P.Foldable f) => f a -> a
sum' = P.foldr (+) zero

newtype Wrapper a = Wrapper a
  deriving (P.Eq, P.Ord, P.Read, P.Show, P.Bounded, P.Generic, P.Generic1,
            P.Functor)
  -- ‘Magma (Sum a)’ is not a unary constraint, as expected by a deriving clause
  -- deriving (Magma (Sum a))
  -- This ^^^ is a major problem

type role Wrapper representational

instance (Magma (Sum a)) => Magma (Sum (Wrapper a)) where
  (Sum (Wrapper a)) `magma` (Sum (Wrapper b)) =
    Sum (Wrapper (coerceFA magma a b))

instance (Unital (Sum a)) => Unital (Sum (Wrapper a)) where
  unit = Sum (Wrapper a) where
    (Sum a) = unit

instance (Associative (Sum a)) => Associative (Sum (Wrapper a))
instance (Commutative (Sum a)) => Commutative (Sum (Wrapper a))

coerceFA :: (Sum a -> Sum a -> Sum a) -> a -> a -> a
coerceFA f a b = let (Sum res) = f (Sum a) (Sum b) in res

coerceTA :: (a -> a -> a) -> (Sum a -> Sum a -> Sum a)
coerceTA f (Sum a) (Sum b) = Sum P.$ f a b