shithub: MicroHs

Download patch

ref: 725d27c12ec61a2f3eae3f1b550cf2875f029c5e
parent: a855d4546080dfe88c5d24cce7a3b9b2e741fcda
author: Lennart Augustsson <lennart@augustsson.net>
date: Mon Sep 23 07:44:22 EDT 2024

Use record selectors for the monoid types.

--- a/lib/Data/Monoid.hs
+++ b/lib/Data/Monoid.hs
@@ -1,28 +1,25 @@
 module Data.Monoid(
   Monoid(..),
-  Endo(..), appEndo,
-  Dual(..), getDual,
-  Max(..), getMax,
-  Min(..), getMin,
-  Sum(..), getSum,
-  Product(..), getProduct,
-  All(..), getAll,
-  Any(..), getAny,
-  Arg(..), ArgMin, ArgMax,
-  Alt(..), getAlt,
-  First(..), getFirst,
-  Last(..), getLast,
+  Endo(..),
+  Dual(..),
+  Sum(..),
+  Product(..),
+  All(..),
+  Any(..),
+  Arg(..),
+  Alt(..),
+  First(..),
+  Last(..),
   ) where
 import Prelude()
 import Data.Maybe_Type
 import Data.Monoid.Internal
+import Data.Records
 
 -- First and Last are different in Monoid and Semigroup,
 -- so put them here.
 
-newtype First a = First (Maybe a)
-getFirst :: forall a . First a -> Maybe a
-getFirst (First a) = a
+newtype First a = First { getFirst :: Maybe a }
 
 instance forall a . Semigroup (First a) where
   a@(First (Just _)) <> _ = a
@@ -32,9 +29,7 @@
   mempty = First Nothing
 
 
-newtype Last a = Last (Maybe a)
-getLast :: forall a . Last a -> Maybe a
-getLast (Last a) = a
+newtype Last a = Last { getLast :: Maybe a }
 
 instance forall a . Semigroup (Last a) where
   _ <> a@(Last (Just _)) = a
--- a/lib/Data/Monoid/Internal.hs
+++ b/lib/Data/Monoid/Internal.hs
@@ -15,6 +15,7 @@
 import Data.Ord
 import Data.Maybe_Type
 import Data.Num
+import Data.Records
 import Text.Show
 
 class Semigroup a => Monoid a where
@@ -27,9 +28,7 @@
 
 ---------------------
 
-newtype Endo a = Endo (a -> a)
-appEndo :: forall a . Endo a -> (a -> a)
-appEndo (Endo f) = f
+newtype Endo a = Endo { appEndo :: a -> a }
 
 instance forall a . Semigroup (Endo a) where
   Endo f <> Endo g = Endo (f . g)
@@ -39,9 +38,8 @@
 
 ---------------------
 
-newtype Dual a = Dual a
-getDual :: forall a . Dual a -> a
-getDual (Dual a) = a
+newtype Dual a = Dual { getDual :: a }
+  deriving (Bounded, Eq, Ord, Show)
 
 instance forall a . Semigroup a => Semigroup (Dual a) where
   Dual a <> Dual b = Dual (b <> a)
@@ -58,12 +56,12 @@
 
 ---------------------
 
-newtype Max a = Max a
-getMax :: forall a . Max a -> a
-getMax (Max a) = a
+newtype Max a = Max { getMax :: a }
+  deriving (Bounded, Eq, Ord, Show)
 
 instance forall a . Ord a => Semigroup (Max a) where
   Max a <> Max b = Max (a `max` b)
+  stimes = stimesIdempotent
 
 instance forall a . (Ord a, Bounded a) => Monoid (Max a) where
   mempty = Max minBound
@@ -70,12 +68,12 @@
 
 ---------------------
 
-newtype Min a = Min a
-getMin :: forall a . Min a -> a
-getMin (Min a) = a
+newtype Min a = Min { getMin :: a }
+  deriving (Bounded, Eq, Ord, Show)
 
 instance forall a . Ord a => Semigroup (Min a) where
   Min a <> Min b = Min (a `min` b)
+  stimes = stimesIdempotent
 
 instance forall a . (Ord a, Bounded a) => Monoid (Min a) where
   mempty = Min maxBound
@@ -82,9 +80,8 @@
 
 ---------------------
 
-newtype Sum a = Sum a
-getSum :: forall a . Sum a -> a
-getSum (Sum a) = a
+newtype Sum a = Sum { getSum :: a }
+  deriving (Bounded, Eq, Ord, Show)
 
 instance forall a . Num a => Semigroup (Sum a) where
   Sum a <> Sum b = Sum (a + b)
@@ -94,9 +91,8 @@
 
 ---------------------
 
-newtype Product a = Product a
-getProduct :: forall a . Product a -> a
-getProduct (Product a) = a
+newtype Product a = Product { getProduct :: a }
+  deriving (Bounded, Eq, Ord, Show)
 
 instance forall a . Num a => Semigroup (Product a) where
   Product a <> Product b = Product (a * b)
@@ -106,9 +102,8 @@
 
 ---------------------
 
-newtype All = All Bool
-getAll :: All -> Bool
-getAll (All a) = a
+newtype All = All { getAll :: Bool }
+  deriving (Bounded, Eq, Ord, Show)
 
 instance Semigroup All where
   All a <> All b = All (a && b)
@@ -118,9 +113,8 @@
 
 ---------------------
 
-newtype Any = Any Bool
-getAny :: Any -> Bool
-getAny (Any a) = a
+newtype Any = Any { getAny :: Bool }
+  deriving (Bounded, Eq, Ord, Show)
 
 instance Semigroup Any where
   Any a <> Any b = Any (a || b)
--- a/lib/Data/Records.hs
+++ b/lib/Data/Records.hs
@@ -9,7 +9,6 @@
 import Primitives
 import Data.Function
 import Data.Proxy
-import Data.Tuple
 
 type Get r a = r -> a
 type Set r a = r -> a -> r
@@ -30,27 +29,3 @@
 composeSet gs1 b_to_c_to_b a c =
   case gs1 a of
     (b, b_to_a) -> b_to_a (b_to_c_to_b b c)
-
------------------------------------
--- Virtual fields for tuples.
-
-instance forall a b . HasField "_1" (a, b) a where getField _ (a, b) = a
-instance forall a b . SetField "_1" (a, b) a where setField _ (a, b) = \ a -> (a, b)
-instance forall a b . HasField "_2" (a, b) b where getField _ (a, b) = b
-instance forall a b . SetField "_2" (a, b) b where setField _ (a, b) = \ b -> (a, b)
-
-instance forall a b c . HasField "_1" (a, b, c) a where getField _ (a, b, c) = a
-instance forall a b c . SetField "_1" (a, b, c) a where setField _ (a, b, c) = \ a -> (a, b, c)
-instance forall a b c . HasField "_2" (a, b, c) b where getField _ (a, b, c) = b
-instance forall a b c . SetField "_2" (a, b, c) b where setField _ (a, b, c) = \ b -> (a, b, c)
-instance forall a b c . HasField "_3" (a, b, c) c where getField _ (a, b, c) = c
-instance forall a b c . SetField "_3" (a, b, c) c where setField _ (a, b, c) = \ c -> (a, b, c)
-
-instance forall a b c d . HasField "_1" (a, b, c, d) a where getField _ (a, b, c, d) = a
-instance forall a b c d . SetField "_1" (a, b, c, d) a where setField _ (a, b, c, d) = \ a -> (a, b, c, d)
-instance forall a b c d . HasField "_2" (a, b, c, d) b where getField _ (a, b, c, d) = b
-instance forall a b c d . SetField "_2" (a, b, c, d) b where setField _ (a, b, c, d) = \ b -> (a, b, c, d)
-instance forall a b c d . HasField "_3" (a, b, c, d) c where getField _ (a, b, c, d) = c
-instance forall a b c d . SetField "_3" (a, b, c, d) c where setField _ (a, b, c, d) = \ c -> (a, b, c, d)
-instance forall a b c d . HasField "_4" (a, b, c, d) d where getField _ (a, b, c, d) = d
-instance forall a b c d . SetField "_4" (a, b, c, d) d where setField _ (a, b, c, d) = \ d -> (a, b, c, d)
--- a/lib/Data/Semigroup.hs
+++ b/lib/Data/Semigroup.hs
@@ -1,18 +1,19 @@
 module Data.Semigroup(
   Semigroup(..),
-  Endo(..), appEndo,
-  Dual(..), getDual,
-  Max(..), getMax,
-  Min(..), getMin,
-  Sum(..), getSum,
-  Product(..), getProduct,
-  All(..), getAll,
-  Any(..), getAny,
+  Endo(..),
+  Dual(..),
+  Max(..),
+  Min(..),
+  Sum(..),
+  Product(..),
+  All(..),
+  Any(..),
   Arg(..), ArgMin, ArgMax,
-  Alt(..), getAlt,
-  First(..), getFirst,
-  Last(..), getLast,
+  Alt(..),
+  First(..),
+  Last(..),
   stimesIdempotent, stimesIdempotentMonoid, stimesMonoid,
+  diff, cycle1,
   ) where
 import Prelude()              -- do not import Prelude
 import Data.Bool
@@ -22,6 +23,7 @@
 import Data.List.NonEmpty_Type
 import Data.Ord
 import Data.Monoid.Internal
+import Data.Records
 import Text.Show
 
 {-
@@ -47,10 +49,8 @@
   enumFromThenTo (First a) (First b) (First c) = First `fmap` enumFromThenTo a b c
 -}
 
-newtype First a = First a
+newtype First a = First { getFirst :: a }
   deriving(Eq, Ord, Show, Bounded)
-getFirst :: First a -> a
-getFirst (First a) = a
 
 instance Semigroup (First a) where
   a <> _ = a
@@ -112,10 +112,8 @@
   enumFromThenTo (Last a) (Last b) (Last c) = Last `fmap` enumFromThenTo a b c
 -}
 
-newtype Last a = Last a
+newtype Last a = Last { getLast :: a }
   deriving(Eq, Ord, Show, Bounded)
-getLast :: Last a -> a
-getLast (Last a) = a
 
 instance Semigroup (Last a) where
   _ <> b = b
@@ -152,3 +150,9 @@
 instance MonadFix Last where
   mfix f = fix (f . getLast)
 -}
+
+diff :: Semigroup m => m -> Endo m
+diff = Endo . (<>)
+
+cycle1 :: Semigroup m => m -> m
+cycle1 xs = xs' where xs' = xs <> xs'
--- a/lib/Data/Tuple.hs
+++ b/lib/Data/Tuple.hs
@@ -12,6 +12,7 @@
 import Data.Function
 import Data.Int
 import Data.Monoid.Internal
+import Data.Records
 import Data.Ord
 import Text.Show
 
@@ -141,3 +142,28 @@
 
 instance forall a b c d . (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a, b, c, d) where
   mempty = (mempty, mempty, mempty, mempty)
+
+
+-----------------------------------
+-- Virtual fields for tuples.
+
+instance forall a b . HasField "_1" (a, b) a where getField _ (a, b) = a
+instance forall a b . SetField "_1" (a, b) a where setField _ (a, b) = \ a -> (a, b)
+instance forall a b . HasField "_2" (a, b) b where getField _ (a, b) = b
+instance forall a b . SetField "_2" (a, b) b where setField _ (a, b) = \ b -> (a, b)
+
+instance forall a b c . HasField "_1" (a, b, c) a where getField _ (a, b, c) = a
+instance forall a b c . SetField "_1" (a, b, c) a where setField _ (a, b, c) = \ a -> (a, b, c)
+instance forall a b c . HasField "_2" (a, b, c) b where getField _ (a, b, c) = b
+instance forall a b c . SetField "_2" (a, b, c) b where setField _ (a, b, c) = \ b -> (a, b, c)
+instance forall a b c . HasField "_3" (a, b, c) c where getField _ (a, b, c) = c
+instance forall a b c . SetField "_3" (a, b, c) c where setField _ (a, b, c) = \ c -> (a, b, c)
+
+instance forall a b c d . HasField "_1" (a, b, c, d) a where getField _ (a, b, c, d) = a
+instance forall a b c d . SetField "_1" (a, b, c, d) a where setField _ (a, b, c, d) = \ a -> (a, b, c, d)
+instance forall a b c d . HasField "_2" (a, b, c, d) b where getField _ (a, b, c, d) = b
+instance forall a b c d . SetField "_2" (a, b, c, d) b where setField _ (a, b, c, d) = \ b -> (a, b, c, d)
+instance forall a b c d . HasField "_3" (a, b, c, d) c where getField _ (a, b, c, d) = c
+instance forall a b c d . SetField "_3" (a, b, c, d) c where setField _ (a, b, c, d) = \ c -> (a, b, c, d)
+instance forall a b c d . HasField "_4" (a, b, c, d) d where getField _ (a, b, c, d) = d
+instance forall a b c d . SetField "_4" (a, b, c, d) d where setField _ (a, b, c, d) = \ d -> (a, b, c, d)
--