diff --git a/.travis.yml b/.travis.yml index e06d3f0..d980b08 100644 --- a/.travis.yml +++ b/.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 && diff --git a/bower.json b/bower.json index 0bce8fb..7b695c2 100644 --- a/bower.json +++ b/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", diff --git a/package.json b/package.json index 132cefc..017bc40 100644 --- a/package.json +++ b/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" } } diff --git a/src/Data/Interval.purs b/src/Data/Interval.purs new file mode 100644 index 0000000..d3c75ad --- /dev/null +++ b/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 diff --git a/src/Data/Interval/Duration.purs b/src/Data/Interval/Duration.purs new file mode 100644 index 0000000..9af57e4 --- /dev/null +++ b/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) diff --git a/src/Data/Interval/Duration/Iso.purs b/src/Data/Interval/Duration/Iso.purs new file mode 100644 index 0000000..10fe187 --- /dev/null +++ b/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) diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 723e51f..35fbfb8 100644 --- a/test/Test/Main.purs +++ b/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