diff --git a/freckle-app.cabal b/freckle-app.cabal index 582057d..13442f7 100644 --- a/freckle-app.cabal +++ b/freckle-app.cabal @@ -43,6 +43,7 @@ library Freckle.App.Exception.MonadUnliftIO Freckle.App.Exception.Types Freckle.App.Faktory.ProducerPool + Freckle.App.Foldable1 Freckle.App.Ghci Freckle.App.GlobalCache Freckle.App.Http @@ -63,6 +64,7 @@ library Freckle.App.Memcached.Client Freckle.App.Memcached.MD5 Freckle.App.Memcached.Servers + Freckle.App.Monoid.Average Freckle.App.OpenTelemetry Freckle.App.OpenTelemetry.Context Freckle.App.OpenTelemetry.Http diff --git a/library/Freckle/App/Foldable1.hs b/library/Freckle/App/Foldable1.hs new file mode 100644 index 0000000..1d2a5b3 --- /dev/null +++ b/library/Freckle/App/Foldable1.hs @@ -0,0 +1,13 @@ +module Freckle.App.Foldable1 (foldMap1') where + +import Freckle.App.Prelude + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup.Foldable (Foldable1) +import Data.Semigroup.Foldable qualified as Foldable1 + +-- | A strict left fold into some @'Semigroup'@ +foldMap1' :: (Foldable1 t, Semigroup m) => (a -> m) -> t a -> m +foldMap1' f = go . Foldable1.toNonEmpty + where + go (a :| as) = foldl' (\acc x -> acc <> f x) (f a) as diff --git a/library/Freckle/App/Monoid/Average.hs b/library/Freckle/App/Monoid/Average.hs new file mode 100644 index 0000000..f4b9bb3 --- /dev/null +++ b/library/Freckle/App/Monoid/Average.hs @@ -0,0 +1,143 @@ +module Freckle.App.Monoid.Average + ( Average (..) + , average + , average1 + , averageDatum + , getAverage + , getAverageInt + , getRoundedAverage + , weightedAverage + , weightedAverages + , AverageableEnum + , averageableEnum + , getAverageableEnum + ) where + +import Freckle.App.Prelude + +import Freckle.App.Foldable1 (foldMap1') +import Autodocodec qualified +import Data.Aeson (ToJSON (..)) +import Data.Semigroup.Foldable (Foldable1) +import Test.QuickCheck + +average :: (Foldable t, Fractional a) => t a -> Maybe a +average = getAverage . foldMap' averageDatum + +average1 :: (Foldable1 t, Fractional a) => t a -> a +average1 = getAverageSafe . foldMap1' averageDatum + where + getAverageSafe (Average l n) = n / fromIntegral l + +data Average n = Average !Int !n + deriving stock (Show) + +deriving via + (Autodocodec.Autodocodec (Average Int)) + instance + (ToJSON (Average Int)) + +deriving via + (Autodocodec.Autodocodec (Average a)) + instance + (Fractional a, Autodocodec.HasCodec a) + => (ToJSON (Average a)) + +instance Arbitrary n => Arbitrary (Average n) where + arbitrary = Average <$> (abs <$> arbitrary @Int) <*> arbitrary @n + +instance (Fractional n, Eq n) => Eq (Average n) where + a == b = getAverage a == getAverage b + +getAverage :: Fractional n => Average n -> Maybe n +getAverage (Average l n) = + if l == 0 then Nothing else Just $ n / fromIntegral l + +getRoundedAverage :: RealFrac n => Average n -> Maybe Int +getRoundedAverage = fmap round . getAverage + +getAverageInt :: Average Int -> Maybe Int +getAverageInt (Average l n) = + roundInt + <$> getAverage (Average l (fromIntegral n)) + where + roundInt = round :: Double -> Int + +-- Calculate a weighted average from a list with integral weights. +-- +-- This is useful for calculating correctness values for assignment sessions. +-- +-- >>> weightedAverages [(0, 2), (1, 1)] +-- Average 3 1 +-- +-- >>> getAverage (weightedAverages [(0, 2), (1, 1)]) +-- Just 0.3333333333333333 +-- +weightedAverages + :: (Integral weight, Foldable f, Num n) => f (n, weight) -> Average n +weightedAverages correctnesses = foldMap avg correctnesses + where + avg (correctness, worth) = weightedAverage worth correctness + +-- Construct a weighted average with integral weights. +-- +-- This is useful for calculating correctness values for assignment sessions. +-- +-- >>> weightedAverage 3 2 +-- Average 6 6 +-- +weightedAverage :: (Integral weight, Num n) => weight -> n -> Average n +weightedAverage weight = + mconcat . replicate (fromIntegral weight) . averageDatum + +averageDatum :: n -> Average n +averageDatum = Average 1 + +instance Num n => Semigroup (Average n) where + Average lx nx <> Average ly ny = Average (lx + ly) (nx + ny) + +instance Num n => Monoid (Average n) where + mempty = Average 0 0 + +-- | Averaging `Int`s is something we often want to do for display purposes. +-- To do this, the average is rounded. +instance {-# OVERLAPPING #-} Autodocodec.HasCodec (Average Int) where + codec = + Autodocodec.bimapCodec + (const $ Left "Can't decode Average") + getAverageInt + (Autodocodec.codec @(Maybe Int)) + +instance (Fractional n, Autodocodec.HasCodec n) => Autodocodec.HasCodec (Average n) where + codec = + Autodocodec.bimapCodec + (const $ Left "Can't decode Average") + getAverage + (Autodocodec.codec @(Maybe n)) + +-- | Representation of an @'Enum'@ type that can be averaged +-- +-- An enumeration can be averaged if it represents evenly-spaced points along a +-- linear path, much like numbers. It works as you would expect: +-- +-- @ +-- data Fruit = Apple | Orange | Pear deriving Enum +-- +-- 'averageEnum' [Apple, Pear] +-- => Just Orange +-- @ +newtype AverageableEnum a + = AverageableEnum (Average Double) + deriving stock (Eq, Show) + deriving newtype (Semigroup, Monoid) + +instance (Arbitrary a, Enum a) => Arbitrary (AverageableEnum a) where + arbitrary = averageableEnum <$> arbitrary @a + +averageableEnum :: Enum a => a -> AverageableEnum a +averageableEnum = + AverageableEnum . averageDatum . fromIntegral . (+ 1) . fromEnum + +getAverageableEnum :: Enum a => AverageableEnum a -> Maybe a +getAverageableEnum (AverageableEnum avg) = + toEnum . subtract 1 <$> getRoundedAverage avg