Add Interval

.travis.yml

@@ -15,7 +15,7 @@ script:
   - bower install --production
   - npm run -s build
   - bower install
-  - npm test
+  - npm run -s test
 after_success:
 - >-
   test $TRAVIS_TAG &&

bower.json

@@ -20,8 +20,9 @@
     "purescript-functions": "^3.0.0",
     "purescript-generics": "^4.0.0",
     "purescript-integers": "^3.0.0",
-    "purescript-math": "^2.0.0",
-    "purescript-foldable-traversable": "^3.0.0"
+    "purescript-foldable-traversable": "^3.0.0",
+    "purescript-maps": "^3.0.0",
+    "purescript-math": "^2.0.0"
   },
   "devDependencies": {
     "purescript-assert": "^3.0.0",

package.json

@@ -7,8 +7,8 @@
   },
   "devDependencies": {
     "eslint": "^3.17.1",
-    "pulp": "^10.0.4",
-    "purescript-psa": "^0.5.0-rc.1",
+    "pulp": "^11.0.x",
+    "purescript-psa": "^0.5.x",
     "rimraf": "^2.6.1"
   }
 }

src/Data/Interval.purs

@@ -0,0 +1,115 @@
+module Data.Interval
+  ( Interval(..)
+  , RecurringInterval(..)
+  , module DurationExports
+  ) where
+
+import Prelude
+
+import Control.Extend (class Extend, extend)
+import Data.Bifoldable (class Bifoldable, bifoldl, bifoldr, bifoldrDefault, bifoldMapDefaultL)
+import Data.Bifunctor (class Bifunctor, bimap)
+import Data.Bitraversable (class Bitraversable, bitraverse, bisequenceDefault)
+import Data.Foldable (class Foldable, foldl, foldr, foldrDefault, foldMapDefaultL)
+import Data.Interval.Duration as DurationExports
+import Data.Maybe (Maybe)
+import Data.Traversable (class Traversable, traverse, sequenceDefault)
+
+data RecurringInterval d a = RecurringInterval (Maybe Int) (Interval d a)
+
+derive instance eqRecurringInterval :: (Eq d, Eq a) => Eq (RecurringInterval d a)
+derive instance ordRecurringInterval :: (Ord d, Ord a) => Ord (RecurringInterval d a)
+instance showRecurringInterval :: (Show d, Show a) => Show (RecurringInterval d a) where
+  show (RecurringInterval x y) = "(RecurringInterval " <> show x <> " " <> show y <> ")"
+
+interval :: ∀ d a. RecurringInterval d a -> Interval d a
+interval (RecurringInterval _ i) = i
+
+over :: ∀ f d a d' a'. Functor f => (Interval d a -> f (Interval d' a')) -> RecurringInterval d a -> f (RecurringInterval d' a')
+over f (RecurringInterval n i) = map (RecurringInterval n) (f i)
+
+instance functorRecurringInterval :: Functor (RecurringInterval d) where
+  map f (RecurringInterval n i) = RecurringInterval n (map f i)
+
+instance bifunctorRecurringInterval :: Bifunctor RecurringInterval where
+  bimap f g (RecurringInterval n i) = RecurringInterval n (bimap f g i)
+
+instance foldableRecurringInterval :: Foldable (RecurringInterval d) where
+  foldl f i = foldl f i <<< interval
+  foldr f i = foldr f i <<< interval
+  foldMap = foldMapDefaultL
+
+instance bifoldableRecurringInterval :: Bifoldable RecurringInterval where
+  bifoldl f g i = bifoldl f g i <<< interval
+  bifoldr f g i = bifoldr f g i <<< interval
+  bifoldMap = bifoldMapDefaultL
+
+instance traversableRecurringInterval :: Traversable (RecurringInterval d) where
+  traverse f i = traverse f `over` i
+  sequence = sequenceDefault
+
+instance bitraversableRecurringInterval :: Bitraversable RecurringInterval where
+  bitraverse l r i = bitraverse l r `over` i
+  bisequence = bisequenceDefault
+
+instance extendRecurringInterval :: Extend (RecurringInterval d) where
+  extend f a@(RecurringInterval n i) = RecurringInterval n (extend (const (f a)) i)
+
+data Interval d a
+  = StartEnd      a a
+  | DurationEnd   d a
+  | StartDuration a d
+  | DurationOnly  d
+
+derive instance eqInterval :: (Eq d, Eq a) => Eq (Interval d a)
+derive instance ordInterval :: (Ord d, Ord a) => Ord (Interval d a)
+instance showInterval :: (Show d, Show a) => Show (Interval d a) where
+  show (StartEnd x y) = "(StartEnd " <> show x <> " " <> show y <> ")"
+  show (DurationEnd d x) = "(DurationEnd " <> show d <> " " <> show x <> ")"
+  show (StartDuration x d) = "(StartDuration " <> show x <> " " <> show d <> ")"
+  show (DurationOnly d) = "(DurationOnly " <> show d <> ")"
+
+instance functorInterval :: Functor (Interval d) where
+  map = bimap id
+
+instance bifunctorInterval :: Bifunctor Interval where
+  bimap _ f (StartEnd x y) = StartEnd (f x) (f y)
+  bimap g f (DurationEnd d x) = DurationEnd (g d) (f x)
+  bimap g f (StartDuration x d) = StartDuration (f x) (g d)
+  bimap g _ (DurationOnly d) = DurationOnly (g d)
+
+instance foldableInterval :: Foldable (Interval d) where
+  foldl f z (StartEnd x y) = (z `f` x) `f` y
+  foldl f z (DurationEnd d x) = z `f` x
+  foldl f z (StartDuration x d) = z `f` x
+  foldl _ z _ = z
+  foldr x = foldrDefault x
+  foldMap = foldMapDefaultL
+
+instance bifoldableInterval :: Bifoldable Interval where
+  bifoldl _ f z (StartEnd x y) = (z `f` x) `f` y
+  bifoldl g f z (DurationEnd d x) = (z `g` d) `f` x
+  bifoldl g f z (StartDuration x d) = (z `g` d) `f` x
+  bifoldl g _ z (DurationOnly d) = z `g` d
+  bifoldr x = bifoldrDefault x
+  bifoldMap = bifoldMapDefaultL
+
+instance traversableInterval :: Traversable (Interval d) where
+  traverse f (StartEnd x y) = StartEnd <$> f x  <*> f y
+  traverse f (DurationEnd d x) = f x <#> DurationEnd d
+  traverse f (StartDuration x d) = f x <#> (_ `StartDuration` d)
+  traverse _ (DurationOnly d) = pure (DurationOnly d)
+  sequence = sequenceDefault
+
+instance bitraversableInterval :: Bitraversable Interval where
+  bitraverse _ r (StartEnd x y) = StartEnd <$> r x <*> r y
+  bitraverse l r (DurationEnd d x) = DurationEnd <$> l d <*> r x
+  bitraverse l r (StartDuration x d) = StartDuration <$> r x <*> l d
+  bitraverse l _ (DurationOnly d) = DurationOnly <$> l d
+  bisequence = bisequenceDefault
+
+instance extendInterval :: Extend (Interval d) where
+  extend f a@(StartEnd x y) = StartEnd (f a) (f a)
+  extend f a@(DurationEnd d x) = DurationEnd d (f a)
+  extend f a@(StartDuration x d) = StartDuration (f a) d
+  extend f (DurationOnly d) = DurationOnly d

src/Data/Interval/Duration.purs

@@ -0,0 +1,74 @@
+module Data.Interval.Duration
+  ( Duration(..)
+  , DurationComponent(..)
+  , year
+  , month
+  , week
+  , day
+  , hour
+  , minute
+  , second
+  , millisecond
+  ) where
+
+import Prelude
+
+import Data.Map as Map
+import Data.Monoid (class Monoid, mempty)
+import Data.Newtype (class Newtype)
+
+newtype Duration = Duration (Map.Map DurationComponent Number)
+
+derive instance eqDuration :: Eq Duration
+derive instance ordDuration :: Ord Duration
+derive instance newtypeDuration :: Newtype Duration _
+
+instance showDuration :: Show Duration where
+  show (Duration d) = "(Duration " <> show d <> ")"
+
+instance semigroupDuration :: Semigroup Duration where
+  append (Duration a) (Duration b) = Duration (Map.unionWith (+) a b)
+
+instance monoidDuration :: Monoid Duration where
+  mempty = Duration mempty
+
+data DurationComponent = Second | Minute | Hour | Day | Week | Month | Year
+derive instance eqDurationComponent :: Eq DurationComponent
+derive instance ordDurationComponent :: Ord DurationComponent
+
+instance showDurationComponent :: Show DurationComponent where
+  show Minute = "Minute"
+  show Second = "Second"
+  show Hour = "Hour"
+  show Day = "Day"
+  show Week = "Week"
+  show Month = "Month"
+  show Year = "Year"
+
+
+week :: Number -> Duration
+week = durationFromComponent Week
+
+year :: Number -> Duration
+year = durationFromComponent Year
+
+month :: Number -> Duration
+month = durationFromComponent Month
+
+day :: Number -> Duration
+day = durationFromComponent Day
+
+hour :: Number -> Duration
+hour = durationFromComponent Hour
+
+minute :: Number -> Duration
+minute = durationFromComponent Minute
+
+second :: Number -> Duration
+second = durationFromComponent Second
+
+millisecond :: Number -> Duration
+millisecond = durationFromComponent Second <<< (_ / 1000.0)
+
+durationFromComponent :: DurationComponent -> Number -> Duration
+durationFromComponent k v = Duration (Map.singleton k v)

src/Data/Interval/Duration/Iso.purs

@@ -0,0 +1,97 @@
+module Data.Interval.Duration.Iso
+  ( IsoDuration
+  , unIsoDuration
+  , mkIsoDuration
+  , Error(..)
+  , Errors
+  , prettyError
+  ) where
+
+import Prelude
+
+import Control.Plus (empty)
+import Data.Either (Either(..))
+import Data.Foldable (fold, foldMap)
+import Data.Interval.Duration (Duration(..), DurationComponent(..))
+import Data.List (List(..), reverse, span, null)
+import Data.List.NonEmpty (fromList)
+import Data.List.Types (NonEmptyList)
+import Data.Map as Map
+import Data.Maybe (Maybe(..), isJust)
+import Data.Monoid.Additive (Additive(..))
+import Data.Newtype (unwrap)
+import Data.Tuple (Tuple(..), snd)
+import Math as Math
+
+newtype IsoDuration = IsoDuration Duration
+
+derive instance eqIsoDuration :: Eq IsoDuration
+derive instance ordIsoDuration :: Ord IsoDuration
+instance showIsoDuration :: Show IsoDuration where
+  show (IsoDuration d) = "(IsoDuration " <> show d <> ")"
+
+type Errors = NonEmptyList Error
+
+data Error
+  = IsEmpty
+  | InvalidWeekComponentUsage
+  | ContainsNegativeValue DurationComponent
+  | InvalidFractionalUse DurationComponent
+
+derive instance eqError :: Eq Error
+derive instance ordError :: Ord Error
+instance showError :: Show Error where
+  show (IsEmpty) = "(IsEmpty)"
+  show (InvalidWeekComponentUsage) = "(InvalidWeekComponentUsage)"
+  show (ContainsNegativeValue c) = "(ContainsNegativeValue " <> show c <> ")"
+  show (InvalidFractionalUse c) = "(InvalidFractionalUse " <> show c <> ")"
+
+prettyError :: Error -> String
+prettyError (IsEmpty) = "Duration is empty (has no components)"
+prettyError (InvalidWeekComponentUsage) = "Week component of Duration is used with other components"
+prettyError (ContainsNegativeValue c) = "Component `" <> show c <> "` contains negative value"
+prettyError (InvalidFractionalUse c) = "Invalid usage of Fractional value at component `" <> show c <> "`"
+
+
+unIsoDuration :: IsoDuration -> Duration
+unIsoDuration (IsoDuration a) = a
+
+mkIsoDuration :: Duration -> Either Errors IsoDuration
+mkIsoDuration d = case fromList (checkValidIsoDuration d) of
+  Just errs -> Left errs
+  Nothing -> Right (IsoDuration d)
+
+checkValidIsoDuration :: Duration -> List Error
+checkValidIsoDuration (Duration asMap) = check {asList, asMap}
+  where
+  asList = reverse (Map.toAscUnfoldable asMap)
+  check = fold
+    [ checkWeekUsage
+    , checkEmptiness
+    , checkFractionalUse
+    , checkNegativeValues
+    ]
+
+
+type CheckEnv =
+  { asList :: List (Tuple DurationComponent Number)
+  , asMap :: Map.Map DurationComponent Number}
+
+checkWeekUsage :: CheckEnv -> List Error
+checkWeekUsage {asMap} = if isJust (Map.lookup Week asMap) && Map.size asMap > 1
+  then pure InvalidWeekComponentUsage else empty
+
+checkEmptiness :: CheckEnv -> List Error
+checkEmptiness {asList} = if null asList then pure IsEmpty else empty
+
+checkFractionalUse :: CheckEnv -> List Error
+checkFractionalUse {asList} = case _.rest (span (snd >>> not isFractional) asList) of
+  Cons (Tuple c _) rest | checkRest rest -> pure (InvalidFractionalUse c)
+  _ -> empty
+  where
+  isFractional a = Math.floor a /= a
+  checkRest rest = unwrap (foldMap (snd >>> Math.abs >>> Additive) rest) > 0.0
+
+checkNegativeValues :: CheckEnv -> List Error
+checkNegativeValues {asList} = flip foldMap asList \(Tuple c num) ->
+  if num >= 0.0 then empty else pure (ContainsNegativeValue c)

test/Test/Main.purs

@@ -4,32 +4,49 @@ import Prelude
 
 import Control.Monad.Eff (Eff)
 import Control.Monad.Eff.Console (CONSOLE, log)
-
-import Data.Enum (class BoundedEnum, Cardinality, toEnum, enumFromTo, cardinality, succ, fromEnum, pred)
-import Data.Date as Date
-import Data.Time as Time
-import Data.Time.Duration as Duration
 import Data.Array as Array
+import Data.Date as Date
 import Data.DateTime as DateTime
-import Data.DateTime.Locale as Locale
 import Data.DateTime.Instant as Instant
+import Data.DateTime.Locale as Locale
+import Data.Either (Either(..), isRight)
+import Data.Enum (class BoundedEnum, Cardinality, toEnum, enumFromTo, cardinality, succ, fromEnum, pred)
 import Data.Foldable (foldl, foldr, foldMap)
+import Data.Interval as Interval
+import Data.Interval.Duration.Iso as IsoDuration
 import Data.Maybe (Maybe(..), fromJust)
+import Data.Monoid (mempty)
+import Data.Newtype (over, unwrap)
 import Data.String (length)
+import Data.Time as Time
+import Data.Time.Duration as Duration
 import Data.Traversable (sequence, traverse)
 import Data.Tuple (Tuple(..), snd)
-import Data.Newtype (over, unwrap)
-
 import Math (floor)
-
-import Type.Proxy (Proxy(..))
-import Test.Assert (ASSERT, assert)
 import Partial.Unsafe (unsafePartial)
+import Test.Assert (ASSERT, assert)
+import Type.Proxy (Proxy(..))
 
 type Tests = Eff (console :: CONSOLE, assert :: ASSERT) Unit
 
 main :: Tests
 main = do
+  log "check Duration monoid"
+  assert $ Interval.year 1.0 == mempty <> Interval.year 2.0 <> Interval.year 1.0 <> Interval.year (-2.0)
+  assert $ Interval.second 0.5 == Interval.millisecond 500.0
+  assert $ IsoDuration.mkIsoDuration (Interval.week 1.2 <> Interval.week 1.2)
+    == IsoDuration.mkIsoDuration (Interval.week 2.4)
+  assert $ isRight $ IsoDuration.mkIsoDuration (Interval.day 1.2 <> mempty)
+  assert $ isRight $ IsoDuration.mkIsoDuration (Interval.day 1.2 <> Interval.second 0.0)
+  assert $ isRight $ IsoDuration.mkIsoDuration (Interval.year 2.0 <> Interval.day 1.0)
+  assert $ IsoDuration.mkIsoDuration (Interval.year 2.5 <> Interval.day 1.0)
+    == Left (pure (IsoDuration.InvalidFractionalUse Interval.Year))
+  log $ show $ IsoDuration.mkIsoDuration (Interval.year 2.5 <> Interval.week 1.0)
+    == Left (pure IsoDuration.InvalidWeekComponentUsage <> pure (IsoDuration.InvalidFractionalUse Interval.Year))
+  assert $ IsoDuration.mkIsoDuration (Interval.year 2.0 <> Interval.day (-1.0))
+    == Left (pure (IsoDuration.ContainsNegativeValue Interval.Day))
+  assert $ IsoDuration.mkIsoDuration (mempty)
+    == Left (pure IsoDuration.IsEmpty)
 
   let epochDate = unsafePartial fromJust $ Date.canonicalDate
                   <$> toEnum 1