Updated Modable

src/Data/DateTime/Gregorian.hs

@@ -5,10 +5,12 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 module Data.DateTime.Gregorian where
 import Data.DateTime.ConstPart
 import Data.DateTime.DateTime
 import Data.DateTime.VarPart
+import Data.Modable
 import Data.Naturals
 import Data.Normalize
 import Data.Ranged
@@ -20,7 +22,9 @@ import Text.Printf (printf)
 
 
 newtype Year = Y Integer deriving
-    (Eq, Ord, Num, Real, Enum, Integral, Parse, Normalize, Arbitrary)
+    ( Eq, Ord, Num, Real, Enum, Integral
+    , Parse, Normalize, Arbitrary, Modable)
+instance Relable Year where type Relative Year = Maybe Year
 instance Zeroed Year where zero = Y 1
 instance Show Year where show (Y y) = show y
 isLeapYear :: Year -> Bool
@@ -32,7 +36,8 @@ isLeapYear y
 
 
 newtype Month = M Int deriving
-    (Eq, Ord, Num, Real, Enum, Integral, Parse, Random)
+    (Eq, Ord, Num, Real, Enum, Integral, Parse, Random, Modable)
+instance Relable Month where type Relative Month = Maybe Month
 instance Arbitrary Month where
     arbitrary = sized $ \s -> choose (M $ - (max s 1000), M (max s 1000))
     shrink (M m) = map M (shrink m)
@@ -43,7 +48,8 @@ instance Ranged Month Year where
 
 
 newtype Day = D Int deriving
-    (Eq, Ord, Num, Real, Enum, Integral, Parse, Random)
+    (Eq, Ord, Num, Real, Enum, Integral, Parse, Random, Modable)
+instance Relable Day where type Relative Day = Maybe Day
 instance Arbitrary Day where
     arbitrary = sized $ \s -> choose (D $ - (max s 1000), D (max s 1000))
     shrink (D d) = map D (shrink d)

src/Data/Modable.hs

@@ -1,9 +1,13 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
 module Data.Modable where
+import Control.Applicative
 import Data.Pair
 import Data.Maybe (fromMaybe)
 
+class Relable a where type Relative a
+
 -- | A class that allows simple 'arithmetic' betwene
 -- | different types. In simplet types, 'b' is 'Maybe a'
 -- | which allows us to do addition between (for instance)
@@ -16,32 +20,51 @@ import Data.Maybe (fromMaybe)
 -- |
 -- | Which adds [Nothing Years, Just 1 Month, Just 30 Days] to
 -- | an existing date.
-class Modable a b where
-    plus :: a -> b -> a
-    minus :: a -> b -> a
-    -- b replaces a, if b is given (and can be converted to a)
-    clobber :: a -> b -> a
+class Relable a => Modable a where
+    plus :: a -> Relative a -> a
+    minus :: a -> Relative a -> a
+    -- b replaces a, if b is capeable
+    clobber :: a -> Relative a -> a
+    relify :: a -> Relative a
+    absify :: Relative a -> Maybe a
+    like :: a -> Relative a -> Bool
 
 
 -- | Helper function for modable pairs
-thread :: Pair p
-    => (a -> x -> a) -> (b -> y -> b)   -- The modifying functions
-    -> p a b -> Maybe (p x y)       -- The pair parameters
-    -> p a b                          -- The resulting pair
+thread :: (Pair p, Pair q, Relable a, Relable b)
+    => (a -> Relative a -> a) -> (b -> Relative b -> b)
+    -> p a b -> Maybe (q (Relative a) (Relative b))
+    -> p a b
 thread f g ab = maybe ab (merge $ tmap f g ab)
 
+instance (Relable a, Relable b, Pair p) => Relable (p a b) where
+    type Relative (p a b) = Maybe ((Relative a), (Relative b))
 
--- | Instances that are modable on Maybe objects
--- | There's a little type system hackery going on here,
--- | so be careful how you make new instances.
-
-instance (Modable a x, Modable b y, Pair p)
-    => Modable (p a b) (Maybe (p x y)) where
+instance (Modable a, Modable b, Pair p) => Modable (p a b) where
     plus = thread plus plus
     minus = thread minus minus
     clobber = thread clobber clobber
+    like _ Nothing = True
+    like p (Just q) = (left p `like` left q) && (right p `like` right q)
+    relify p = Just (build (relify $ left p) (relify $ right p))
+    absify = (join =<<) where
+        join p = build <$> (absify $ left p) <*> (absify $ right p)
+
+
+instance Relable Integer where type Relative Integer = Maybe Integer
+instance Modable Integer where
+    plus a = maybe a (a+)
+    minus a = maybe a (a-)
+    clobber = fromMaybe
+    like a = maybe True (a ==)
+    absify = id
+    relify = pure
 
-instance Num a => Modable a (Maybe a) where
+instance Relable Int where type Relative Int = Maybe Int
+instance Modable Int where
     plus a = maybe a (a+)
     minus a = maybe a (a-)
     clobber = fromMaybe
+    like a = maybe True (a ==)
+    absify = id
+    relify = pure

src/Data/Naturals.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Data.Naturals where
 import Control.Applicative
@@ -73,10 +74,15 @@ instance Natural n => Integral (Succ n) where
     toInteger (Z x) = x
     quotRem (Z x) (Z y) = (fromInteger *** fromInteger) (quotRem x y)
 
-instance Natural n => Modable (Succ n) (Maybe (Succ n)) where
+instance Natural n => Relable (Succ n) where
+    type Relative (Succ n) = Maybe (Succ n)
+instance Natural n => Modable (Succ n) where
     plus a = maybe a (a+)
     minus a = maybe a (a-)
     clobber = fromMaybe
+    like a = maybe True (a ==)
+    absify = id
+    relify = pure
 
 instance Natural n => Show (Succ n) where
     show z@(Z x) = printf (printf "%%0%dd" $ digits $ normal z) x where

src/Data/Pair.hs

@@ -12,6 +12,9 @@ module Data.Pair
 class Pair p where
     toTuple :: p a b -> (a, b)
     fromTuple :: (a, b) -> p a b
+    fromTuple = uncurry build
+    build :: a -> b -> p a b
+    build = (fromTuple .) . (,)
 
 -- | The simple tuple instance
 instance Pair (,) where
@@ -28,7 +31,7 @@ right = snd . toTuple
 
 -- | Map two functions across the pair, the first one
 -- | being applied to the left, the second to the right
-tmap :: Pair p => (a -> x) -> (b -> y) -> p a b -> p x y
+tmap :: (Pair p, Pair q) => (a -> x) -> (b -> y) -> p a b -> q x y
 tmap f g ab = fromTuple (f $ left ab, g $ right ab)
 
 -- | Map one function (of two parameters) across the pair,
@@ -38,9 +41,9 @@ summarize f ab = f (left ab) (right ab)
 
 -- | Merge a pair (of functions) with a pair (of parameters)
 -- | generating a new pair
-merge :: Pair p => p (f -> x) (g -> y) -> p f g -> p x y
+merge :: (Pair p, Pair q) => p (f -> x) (g -> y) -> p f g -> q x y
 merge fn xs = fromTuple (left fn $ left xs, right fn $ right xs)
 
 -- | Apply one function to both elements of a homogenous pair
-both :: Pair p => (a -> b) -> p a a -> p b b
+both :: (Pair p, Pair q) => (a -> b) -> p a a -> q b b
 both f = tmap f f

src/Test/Data/Modable.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+module Test.Data.Modable where
+import Data.Maybe (isNothing)
+import Data.Modable
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+
+testModable :: forall a b.
+    ( Eq a, Show a, Arbitrary a
+    , Eq (Relative a), Show (Relative a), Arbitrary (Relative a)
+    , Relative a ~ Maybe b
+    , Modable a
+    ) => a -> Test
+testModable _ = testGroup "maybe math"
+    [ testProperty "plus→minus" (\(a::a) (b::Relative a) ->
+        minus (plus a b) b == a)
+    , testProperty "minus→plus" (\(a::a) (b::Relative a) ->
+        plus (minus a b) b == a)
+    , testProperty "extract clobber" (\(a::a) (b::Relative a) ->
+        if isNothing b
+            then clobber a b == a
+            else clobber a b `like` b)
+    ]

src/Test/Main.hs

@@ -1,9 +1,15 @@
+{-# LANGUAGE TypeOperators #-}
+import Data.DateTime.VarPart
+import Data.DateTime.ConstPart
+
+
 import Test.Framework
 import Test.Framework.Providers.QuickCheck2
 import Test.QuickCheck
 
 import Test.Data.Coded
 import Test.Data.Enum
+import Test.Data.Modable
 import Test.Data.Zeroed
 
 import Data.DateTime.Gregorian
@@ -15,17 +21,21 @@ main = defaultMain tests
 tests :: [Test]
 tests =
     [ testGroup "YMD"
-        [ testEnum (undefined::Year)
-        , testEnum (undefined::Month)
-        , testEnum (undefined::Day)
-        , testEnum (undefined::YMD)
+        [ testEnum (undefined::YMD)
         , testCoded (undefined::YMD)
+        , testModable (undefined::YMD)
         ]
-    , testGroup "HMS"
-        [ testEnum (undefined::N24)
+    , testGroup "Naturals"
+        [ testEnum (undefined::N1)
+        , testEnum (undefined::N24)
         , testEnum (undefined::N60)
-        , testEnum (undefined::HMS)
+        , testEnum (undefined::N100)
+        , testEnum (undefined::N256)
+        ]
+    , testGroup "HMS"
+        [ testEnum (undefined::HMS)
         , testCoded (undefined::HMS)
+        , testModable (undefined::HMS)
         ]
     , testZeroed
     ]