WIP Interval formatters

Author: safareli

src/Data/Formatter/Interval.purs

@@ -0,0 +1,60 @@
+module Data.Formatter.Interval
+  -- TODO parser should't be exposed
+  ( parseDuration
+  ) where
+
+import Prelude
+import Data.Interval as I
+import Text.Parsing.Parser as P
+import Text.Parsing.Parser.Combinators as PC
+import Text.Parsing.Parser.String as PS
+import Control.Alt ((<|>))
+import Data.Array (length, some)
+import Data.Formatter.Internal (digit, foldDigits)
+import Data.Int (toNumber)
+import Data.Monoid (mempty)
+
+
+nums ∷ P.Parser String Int
+nums = foldDigits <$> some digit
+
+-- TODO try to use unformatNumberParser here
+number ∷ P.Parser String Number
+number = do
+  whole ← nums
+  _ ← (PC.try $ PS.string ".") <|> (PC.try $ PS.string ",") <|> pure ""
+  restdigits ← PC.try (some digit) <|> pure [0]
+  let rest = foldDigits restdigits
+  pure $ if rest == 0 then toNumber whole else toNumber whole + ((toNumber rest) / (toNumber $ length restdigits))
+
+
+
+component ∷ String → P.Parser String Number
+component designator = number <* PS.string designator
+
+tryOr :: ∀ a. a → P.Parser String a → P.Parser String a
+tryOr a p = PC.option a $ PC.try p
+
+parseDuration :: P.Parser String (I.Duration)
+-- parseDuration = PS.string "P" *> weekDuration
+parseDuration = PS.string "P" *> (weekDuration <|> fullDuration)-- <* PS.eof
+  where
+    weekDuration :: P.Parser String I.Duration
+    weekDuration = PC.try $ I.week <$> component "W"
+
+    fullDuration ∷ P.Parser String I.Duration
+    fullDuration = append <$> durationDatePart <*> durationTimePart
+
+    durationDatePart ∷ P.Parser String I.Duration
+    durationDatePart = (\y m d → I.year y <> I.month m <> I.day d)
+      <$> (tryOr 0.0 $ component "Y")
+      <*> (tryOr 0.0 $ component "M")
+      <*> (tryOr 0.0 $ component "D")
+
+    durationTimePart ∷ P.Parser String I.Duration
+    durationTimePart = tryOr mempty $
+      PS.string "T" *>
+        pure (\h m s → I.hours h <> I.minutes m <> I.seconds s)
+          <*> (tryOr 0.0 $ component "H")
+          <*> (tryOr 0.0 $ component "M")
+          <*> (tryOr 0.0 $ component "S")

src/Data/Formatter/Number.purs

@@ -11,6 +11,8 @@ module Data.Formatter.Number
   , formatNumber
   , formatOrShowNumber
   , unformatNumber
+  -- TODO move to internal or add doc
+  , unformatNumberParser
   ) where
 
 import Prelude
@@ -20,7 +22,7 @@ import Data.Array as Arr
 import Data.Array (many, some)
 import Data.Maybe (Maybe(..), fromMaybe, isJust)
 import Data.Traversable (for)
-import Data.Either (Either, either)
+import Data.Either (Either(..), either)
 import Data.Int as Int
 import Data.String as Str
 
@@ -217,6 +219,11 @@ unformatNumber ∷ String → String → Either String Number
 unformatNumber pattern str =
   parseFormatString pattern >>= flip unformat str
 
+unformatNumberParser ∷ String → P.Parser String Number
+unformatNumberParser pattern = case P.runParser pattern formatParser of
+    Left e → P.fail $ P.parseErrorMessage e
+    Right p → unformatParser p
+
 -- Supposed to be used in chaining, because after calling format number there is no
 -- good way to extract number back to show.
 formatOrShowNumber ∷ String → Number → String

src/Data/Interval.purs

@@ -0,0 +1,134 @@
+-- TODO commiting this temporarly as depending on my fork of datetime is
+-- not possibel as this module is not updated to [email protected]
+module Data.Interval
+  ( Duration
+  , Interval(..)
+  , RecurringInterval(..)
+  , year
+  , month
+  , week
+  , day
+  , hours
+  , minutes
+  , seconds
+  , milliseconds
+  ) where
+
+import Prelude
+
+import Data.Foldable (class Foldable, foldrDefault, foldMapDefaultL)
+import Data.Traversable (class Traversable, sequenceDefault)
+import Data.Monoid (class Monoid, mempty)
+import Control.Extend (class Extend)
+
+import Data.Maybe (Maybe)
+import Data.List (List(..), (:))
+import Data.Tuple (Tuple(..))
+
+
+data RecurringInterval a = RecurringInterval (Maybe Int) (Interval a)
+
+data Interval a
+  = StartEnd      a a
+  | DurationEnd   Duration a
+  | StartDuration a Duration
+  | JustDuration  Duration
+
+instance showInterval ∷ (Show a) => Show (Interval 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 (JustDuration d) = "(JustDuration " <> show d <> ")"
+
+instance functorInterval ∷ Functor Interval where
+  map f (StartEnd x y) = StartEnd (f x) (f y )
+  map f (DurationEnd d x) = DurationEnd d (f x )
+  map f (StartDuration x d) = StartDuration (f x) d
+  map _ (JustDuration d) = JustDuration d
+
+instance foldableInterval ∷ Foldable Interval 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 traversableInterval ∷ Traversable Interval 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 _ (JustDuration d)  = pure (JustDuration d)
+  sequence = sequenceDefault
+
+instance extendInterval ∷ Extend Interval 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 (JustDuration d) = JustDuration d
+
+
+data Duration = Duration DurationIn
+type DurationIn = List (Tuple DurationComponent Number)
+
+-- TODO `day 1 == hours 24`
+derive instance eqDuration ∷ Eq Duration
+instance showDuration ∷ Show Duration where
+  show (Duration d)= "(Duration " <> show d <> ")"
+
+instance semigroupDuration ∷ Semigroup Duration where
+  append (Duration a) (Duration b) = Duration (appendComponents a b)
+
+instance monoidDuration ∷ Monoid Duration where
+  mempty = Duration mempty
+
+appendComponents ∷ DurationIn → DurationIn → DurationIn
+appendComponents Nil x = x
+appendComponents x Nil = x
+appendComponents ass@(a:as) bss@(b:bs) = case a, b of
+  Tuple aC aV, Tuple bC bV
+    | aC >  bC → a : appendComponents as bss
+    | aC <  bC → b : appendComponents ass bs
+    | otherwise → Tuple aC (aV + bV) : appendComponents as bs
+
+data DurationComponent =  Seconds | Minutes | Hours | Day | Month | Year
+
+instance showDurationComponent ∷ Show DurationComponent where
+  show Year = "Year"
+  show Month = "Month"
+  show Day = "Day"
+  show Hours = "Hours"
+  show Minutes = "Minutes"
+  show Seconds = "Seconds"
+
+derive instance eqDurationComponent ∷ Eq DurationComponent
+derive instance ordDurationComponent ∷ Ord DurationComponent
+
+
+week ∷ Number → Duration
+week = durationFromComponent Day <<< (_ * 7.0)
+
+year ∷ Number → Duration
+year = durationFromComponent Year
+
+month ∷ Number → Duration
+month = durationFromComponent Month
+
+day ∷ Number → Duration
+day = durationFromComponent Day
+
+hours ∷ Number → Duration
+hours = durationFromComponent Hours
+
+minutes ∷ Number → Duration
+minutes = durationFromComponent Minutes
+
+seconds ∷ Number → Duration
+seconds = durationFromComponent Seconds
+
+milliseconds ∷ Number → Duration
+milliseconds = durationFromComponent Seconds <<< (_ / 1000.0)
+
+durationFromComponent ∷ DurationComponent → Number →  Duration
+durationFromComponent c 0.0 = mempty
+durationFromComponent c n = Duration $ pure $ Tuple c n

test/src/Main.purs

@@ -4,6 +4,12 @@ import Prelude
 import Control.Monad.Aff.Console as AffC
 import Data.Date as D
 import Data.DateTime as DTi
+
+-- TODO parser should't be exposed so this should be removed
+import Text.Parsing.Parser as P
+import Data.Interval as I
+import Data.Formatter.Interval as FI
+
 import Data.Formatter.DateTime as FDT
 import Data.Formatter.Number as FN
 import Data.Time as T
@@ -155,7 +161,20 @@ assertFormatting target' format dateTime = do
     ((show result) <> " equals " <> (show target))
     (result == target)
 
+assertParserRes :: forall a e. (Show a, Eq a) => a -> a -> Tests e Unit
+assertParserRes result target =
+  assert
+    ((show result) <> " does not equal " <> (show target))
+    ((show result) <> " equals " <> (show target))
+    (result == target)
 
+timeInterval :: forall e. Tests e Unit
+timeInterval = do
+  log "- Data.Formatter.Interval.parseDuration"
+  assertParserRes (P.runParser "P1W" FI.parseDuration) (Right $ I.day 7.0)
+  assertParserRes (P.runParser "P1.0W" FI.parseDuration) (Right $ I.day 7.0)
+  assertParserRes (P.runParser "P1.0D" FI.parseDuration) (Right $ I.day 1.0)
+  assertParserRes (P.runParser "P1DT1H1M1S" FI.parseDuration) (Right $ I.day 1.0 <> I.hours 1.0 <> I.minutes 1.0 <> I.seconds 1.0)
 timeTest :: forall e. Tests e Unit
 timeTest = do
   log "- Data.Formatter.DateTime.formatDateTime"
@@ -217,6 +236,7 @@ main = execTests tests true
   tests = do
     log "Testing time functions..."
     timeTest
+    timeInterval
     passed <- get
     when (passed /= true) (throwError (error "Tests did not pass."))
     --numeralTests