-- Copyright (c) 2016-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is licensed under the BSD-style license found in the
-- LICENSE file in the root directory of this source tree.
{- HLINT ignore "Use foldr1OrError" -}


{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoRebindableSyntax #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

module Duckling.Time.Types where

import Control.DeepSeq
import Data.Aeson
import Data.Foldable (find)
import Data.Hashable
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import Data.Tuple.Extra (both)
import GHC.Generics
import Prelude
import TextShow (showt)
import qualified Data.HashMap.Strict as H
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Time as Time
import qualified Data.Time.Calendar.WeekDate as Time
import qualified Data.Time.LocalTime.TimeZone.Series as Series

import Duckling.Resolve
import Duckling.TimeGrain.Types (Grain)
import qualified Duckling.TimeGrain.Types as TG

data TimeObject = TimeObject
  { TimeObject -> UTCTime
start :: Time.UTCTime
  , TimeObject -> Grain
grain :: Grain
  , TimeObject -> Maybe UTCTime
end :: Maybe Time.UTCTime
  } deriving (TimeObject -> TimeObject -> Bool
(TimeObject -> TimeObject -> Bool)
-> (TimeObject -> TimeObject -> Bool) -> Eq TimeObject
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeObject -> TimeObject -> Bool
$c/= :: TimeObject -> TimeObject -> Bool
== :: TimeObject -> TimeObject -> Bool
$c== :: TimeObject -> TimeObject -> Bool
Eq, Int -> TimeObject -> ShowS
[TimeObject] -> ShowS
TimeObject -> String
(Int -> TimeObject -> ShowS)
-> (TimeObject -> String)
-> ([TimeObject] -> ShowS)
-> Show TimeObject
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeObject] -> ShowS
$cshowList :: [TimeObject] -> ShowS
show :: TimeObject -> String
$cshow :: TimeObject -> String
showsPrec :: Int -> TimeObject -> ShowS
$cshowsPrec :: Int -> TimeObject -> ShowS
Show)

data Form = DayOfWeek
  | TimeOfDay
    { Form -> Maybe Int
hours :: Maybe Int
    , Form -> Bool
is12H :: Bool
    }
  | Month { Form -> Int
month :: Int }
  | PartOfDay
  deriving (Form -> Form -> Bool
(Form -> Form -> Bool) -> (Form -> Form -> Bool) -> Eq Form
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Form -> Form -> Bool
$c/= :: Form -> Form -> Bool
== :: Form -> Form -> Bool
$c== :: Form -> Form -> Bool
Eq, (forall x. Form -> Rep Form x)
-> (forall x. Rep Form x -> Form) -> Generic Form
forall x. Rep Form x -> Form
forall x. Form -> Rep Form x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Form x -> Form
$cfrom :: forall x. Form -> Rep Form x
Generic, Int -> Form -> Int
Form -> Int
(Int -> Form -> Int) -> (Form -> Int) -> Hashable Form
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Form -> Int
$chash :: Form -> Int
hashWithSalt :: Int -> Form -> Int
$chashWithSalt :: Int -> Form -> Int
Hashable, Int -> Form -> ShowS
[Form] -> ShowS
Form -> String
(Int -> Form -> ShowS)
-> (Form -> String) -> ([Form] -> ShowS) -> Show Form
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Form] -> ShowS
$cshowList :: [Form] -> ShowS
show :: Form -> String
$cshow :: Form -> String
showsPrec :: Int -> Form -> ShowS
$cshowsPrec :: Int -> Form -> ShowS
Show, Eq Form
Eq Form
-> (Form -> Form -> Ordering)
-> (Form -> Form -> Bool)
-> (Form -> Form -> Bool)
-> (Form -> Form -> Bool)
-> (Form -> Form -> Bool)
-> (Form -> Form -> Form)
-> (Form -> Form -> Form)
-> Ord Form
Form -> Form -> Bool
Form -> Form -> Ordering
Form -> Form -> Form
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Form -> Form -> Form
$cmin :: Form -> Form -> Form
max :: Form -> Form -> Form
$cmax :: Form -> Form -> Form
>= :: Form -> Form -> Bool
$c>= :: Form -> Form -> Bool
> :: Form -> Form -> Bool
$c> :: Form -> Form -> Bool
<= :: Form -> Form -> Bool
$c<= :: Form -> Form -> Bool
< :: Form -> Form -> Bool
$c< :: Form -> Form -> Bool
compare :: Form -> Form -> Ordering
$ccompare :: Form -> Form -> Ordering
$cp1Ord :: Eq Form
Ord, Form -> ()
(Form -> ()) -> NFData Form
forall a. (a -> ()) -> NFData a
rnf :: Form -> ()
$crnf :: Form -> ()
NFData)

data IntervalDirection = Before | After
  deriving (IntervalDirection -> IntervalDirection -> Bool
(IntervalDirection -> IntervalDirection -> Bool)
-> (IntervalDirection -> IntervalDirection -> Bool)
-> Eq IntervalDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IntervalDirection -> IntervalDirection -> Bool
$c/= :: IntervalDirection -> IntervalDirection -> Bool
== :: IntervalDirection -> IntervalDirection -> Bool
$c== :: IntervalDirection -> IntervalDirection -> Bool
Eq, (forall x. IntervalDirection -> Rep IntervalDirection x)
-> (forall x. Rep IntervalDirection x -> IntervalDirection)
-> Generic IntervalDirection
forall x. Rep IntervalDirection x -> IntervalDirection
forall x. IntervalDirection -> Rep IntervalDirection x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IntervalDirection x -> IntervalDirection
$cfrom :: forall x. IntervalDirection -> Rep IntervalDirection x
Generic, Int -> IntervalDirection -> Int
IntervalDirection -> Int
(Int -> IntervalDirection -> Int)
-> (IntervalDirection -> Int) -> Hashable IntervalDirection
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: IntervalDirection -> Int
$chash :: IntervalDirection -> Int
hashWithSalt :: Int -> IntervalDirection -> Int
$chashWithSalt :: Int -> IntervalDirection -> Int
Hashable, Eq IntervalDirection
Eq IntervalDirection
-> (IntervalDirection -> IntervalDirection -> Ordering)
-> (IntervalDirection -> IntervalDirection -> Bool)
-> (IntervalDirection -> IntervalDirection -> Bool)
-> (IntervalDirection -> IntervalDirection -> Bool)
-> (IntervalDirection -> IntervalDirection -> Bool)
-> (IntervalDirection -> IntervalDirection -> IntervalDirection)
-> (IntervalDirection -> IntervalDirection -> IntervalDirection)
-> Ord IntervalDirection
IntervalDirection -> IntervalDirection -> Bool
IntervalDirection -> IntervalDirection -> Ordering
IntervalDirection -> IntervalDirection -> IntervalDirection
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IntervalDirection -> IntervalDirection -> IntervalDirection
$cmin :: IntervalDirection -> IntervalDirection -> IntervalDirection
max :: IntervalDirection -> IntervalDirection -> IntervalDirection
$cmax :: IntervalDirection -> IntervalDirection -> IntervalDirection
>= :: IntervalDirection -> IntervalDirection -> Bool
$c>= :: IntervalDirection -> IntervalDirection -> Bool
> :: IntervalDirection -> IntervalDirection -> Bool
$c> :: IntervalDirection -> IntervalDirection -> Bool
<= :: IntervalDirection -> IntervalDirection -> Bool
$c<= :: IntervalDirection -> IntervalDirection -> Bool
< :: IntervalDirection -> IntervalDirection -> Bool
$c< :: IntervalDirection -> IntervalDirection -> Bool
compare :: IntervalDirection -> IntervalDirection -> Ordering
$ccompare :: IntervalDirection -> IntervalDirection -> Ordering
$cp1Ord :: Eq IntervalDirection
Ord, Int -> IntervalDirection -> ShowS
[IntervalDirection] -> ShowS
IntervalDirection -> String
(Int -> IntervalDirection -> ShowS)
-> (IntervalDirection -> String)
-> ([IntervalDirection] -> ShowS)
-> Show IntervalDirection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IntervalDirection] -> ShowS
$cshowList :: [IntervalDirection] -> ShowS
show :: IntervalDirection -> String
$cshow :: IntervalDirection -> String
showsPrec :: Int -> IntervalDirection -> ShowS
$cshowsPrec :: Int -> IntervalDirection -> ShowS
Show, IntervalDirection -> ()
(IntervalDirection -> ()) -> NFData IntervalDirection
forall a. (a -> ()) -> NFData a
rnf :: IntervalDirection -> ()
$crnf :: IntervalDirection -> ()
NFData)

data TimeData = TimeData
  { TimeData -> Predicate
timePred :: Predicate
  , TimeData -> Bool
latent :: Bool
  , TimeData -> Grain
timeGrain :: Grain -- needed for intersect
  , TimeData -> Bool
notImmediate :: Bool
  , TimeData -> Maybe Form
form :: Maybe Form
  , TimeData -> Maybe IntervalDirection
direction :: Maybe IntervalDirection
  , TimeData -> Bool
okForThisNext :: Bool -- allows specific this+Time
  , TimeData -> Maybe Text
holiday :: Maybe Text
  , TimeData -> Bool
hasTimezone :: Bool -- hack to prevent double timezone parsing
  }

instance Eq TimeData where
  == :: TimeData -> TimeData -> Bool
(==) (TimeData Predicate
_ Bool
l1 Grain
g1 Bool
n1 Maybe Form
f1 Maybe IntervalDirection
d1 Bool
_ Maybe Text
_ Bool
t1) (TimeData Predicate
_ Bool
l2 Grain
g2 Bool
n2 Maybe Form
f2 Maybe IntervalDirection
d2 Bool
_ Maybe Text
_ Bool
t2) =
    Bool
l1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
l2 Bool -> Bool -> Bool
&& Grain
g1 Grain -> Grain -> Bool
forall a. Eq a => a -> a -> Bool
== Grain
g2 Bool -> Bool -> Bool
&& Bool
n1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
n2 Bool -> Bool -> Bool
&& Maybe Form
f1 Maybe Form -> Maybe Form -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Form
f2 Bool -> Bool -> Bool
&& Maybe IntervalDirection
d1 Maybe IntervalDirection -> Maybe IntervalDirection -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe IntervalDirection
d2 Bool -> Bool -> Bool
&& Bool
t1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
t2

instance Hashable TimeData where
  hashWithSalt :: Int -> TimeData -> Int
hashWithSalt Int
s (TimeData Predicate
_ Bool
latent Grain
grain Bool
imm Maybe Form
form Maybe IntervalDirection
dir Bool
_ Maybe Text
_ Bool
_) = Int
-> (Int, (Bool, Grain, Bool, Maybe Form, Maybe IntervalDirection))
-> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s
    (Int
0::Int, (Bool
latent, Grain
grain, Bool
imm, Maybe Form
form, Maybe IntervalDirection
dir))

instance Ord TimeData where
  compare :: TimeData -> TimeData -> Ordering
compare (TimeData Predicate
_ Bool
l1 Grain
g1 Bool
n1 Maybe Form
f1 Maybe IntervalDirection
d1 Bool
_ Maybe Text
_ Bool
_) (TimeData Predicate
_ Bool
l2 Grain
g2 Bool
n2 Maybe Form
f2 Maybe IntervalDirection
d2 Bool
_ Maybe Text
_ Bool
_) =
    case Grain -> Grain -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Grain
g1 Grain
g2 of
      Ordering
EQ -> case Maybe Form -> Maybe Form -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Maybe Form
f1 Maybe Form
f2 of
        Ordering
EQ -> case Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Bool
l1 Bool
l2 of
          Ordering
EQ -> case Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Bool
n1 Bool
n2 of
            Ordering
EQ -> Maybe IntervalDirection -> Maybe IntervalDirection -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Maybe IntervalDirection
d1 Maybe IntervalDirection
d2
            Ordering
z -> Ordering
z
          Ordering
z -> Ordering
z
        Ordering
z -> Ordering
z
      Ordering
z -> Ordering
z

instance Show TimeData where
  show :: TimeData -> String
show (TimeData Predicate
_ Bool
latent Grain
grain Bool
_ Maybe Form
form Maybe IntervalDirection
dir Bool
_ Maybe Text
holiday Bool
tz) =
    String
"TimeData{" String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
"latent=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
latent String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
", grain=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Grain -> String
forall a. Show a => a -> String
show Grain
grain String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
", form=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Form -> String
forall a. Show a => a -> String
show Maybe Form
form String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
", direction=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe IntervalDirection -> String
forall a. Show a => a -> String
show Maybe IntervalDirection
dir String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
", holiday=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Text -> String
forall a. Show a => a -> String
show Maybe Text
holiday String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
", hasTimezone=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
tz String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
"}"

instance NFData TimeData where
  rnf :: TimeData -> ()
rnf TimeData{Bool
Maybe Text
Maybe IntervalDirection
Maybe Form
Grain
Predicate
hasTimezone :: Bool
holiday :: Maybe Text
okForThisNext :: Bool
direction :: Maybe IntervalDirection
form :: Maybe Form
notImmediate :: Bool
timeGrain :: Grain
latent :: Bool
timePred :: Predicate
hasTimezone :: TimeData -> Bool
holiday :: TimeData -> Maybe Text
okForThisNext :: TimeData -> Bool
direction :: TimeData -> Maybe IntervalDirection
form :: TimeData -> Maybe Form
notImmediate :: TimeData -> Bool
timeGrain :: TimeData -> Grain
latent :: TimeData -> Bool
timePred :: TimeData -> Predicate
..} = (Bool, Grain, Bool, Maybe Form, Maybe IntervalDirection) -> ()
forall a. NFData a => a -> ()
rnf (Bool
latent, Grain
timeGrain, Bool
notImmediate, Maybe Form
form, Maybe IntervalDirection
direction)

instance Resolve TimeData where
  type ResolvedValue TimeData = TimeValue
  resolve :: Context
-> Options -> TimeData -> Maybe (ResolvedValue TimeData, Bool)
resolve Context
_ Options {withLatent :: Options -> Bool
withLatent = Bool
False} TimeData {latent :: TimeData -> Bool
latent = Bool
True} = Maybe (ResolvedValue TimeData, Bool)
forall a. Maybe a
Nothing
  resolve Context
context Options
_ TimeData {Predicate
timePred :: Predicate
timePred :: TimeData -> Predicate
timePred, Bool
latent :: Bool
latent :: TimeData -> Bool
latent, Bool
notImmediate :: Bool
notImmediate :: TimeData -> Bool
notImmediate, Maybe IntervalDirection
direction :: Maybe IntervalDirection
direction :: TimeData -> Maybe IntervalDirection
direction, Maybe Text
holiday :: Maybe Text
holiday :: TimeData -> Maybe Text
holiday} = do
    TimeObject
value <- case [TimeObject]
future of
      [] -> [TimeObject] -> Maybe TimeObject
forall a. [a] -> Maybe a
listToMaybe [TimeObject]
past
      TimeObject
ahead:TimeObject
nextAhead:[TimeObject]
_
        | Bool
notImmediate Bool -> Bool -> Bool
&& Maybe TimeObject -> Bool
forall a. Maybe a -> Bool
isJust (TimeObject -> TimeObject -> Maybe TimeObject
timeIntersect TimeObject
ahead TimeObject
refTime) -> TimeObject -> Maybe TimeObject
forall a. a -> Maybe a
Just TimeObject
nextAhead
      TimeObject
ahead:[TimeObject]
_ -> TimeObject -> Maybe TimeObject
forall a. a -> Maybe a
Just TimeObject
ahead
    [TimeObject]
values <- [TimeObject] -> Maybe [TimeObject]
forall a. a -> Maybe a
Just ([TimeObject] -> Maybe [TimeObject])
-> [TimeObject] -> Maybe [TimeObject]
forall a b. (a -> b) -> a -> b
$ Int -> [TimeObject] -> [TimeObject]
forall a. Int -> [a] -> [a]
take Int
3 ([TimeObject] -> [TimeObject]) -> [TimeObject] -> [TimeObject]
forall a b. (a -> b) -> a -> b
$ if [TimeObject] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null [TimeObject]
future then [TimeObject]
past else [TimeObject]
future
    (TimeValue, Bool) -> Maybe (TimeValue, Bool)
forall a. a -> Maybe a
Just ((TimeValue, Bool) -> Maybe (TimeValue, Bool))
-> (TimeValue, Bool) -> Maybe (TimeValue, Bool)
forall a b. (a -> b) -> a -> b
$ case Maybe IntervalDirection
direction of
      Maybe IntervalDirection
Nothing -> (SingleTimeValue -> [SingleTimeValue] -> Maybe Text -> TimeValue
TimeValue (TimeZoneSeries -> TimeObject -> SingleTimeValue
timeValue TimeZoneSeries
tzSeries TimeObject
value)
        ((TimeObject -> SingleTimeValue)
-> [TimeObject] -> [SingleTimeValue]
forall a b. (a -> b) -> [a] -> [b]
map (TimeZoneSeries -> TimeObject -> SingleTimeValue
timeValue TimeZoneSeries
tzSeries) [TimeObject]
values) Maybe Text
holiday, Bool
latent)
      Just IntervalDirection
d -> (SingleTimeValue -> [SingleTimeValue] -> Maybe Text -> TimeValue
TimeValue (TimeZoneSeries
-> IntervalDirection -> TimeObject -> SingleTimeValue
openInterval TimeZoneSeries
tzSeries IntervalDirection
d TimeObject
value)
        ((TimeObject -> SingleTimeValue)
-> [TimeObject] -> [SingleTimeValue]
forall a b. (a -> b) -> [a] -> [b]
map (TimeZoneSeries
-> IntervalDirection -> TimeObject -> SingleTimeValue
openInterval TimeZoneSeries
tzSeries IntervalDirection
d) [TimeObject]
values) Maybe Text
holiday, Bool
latent)
    where
      DucklingTime (Series.ZoneSeriesTime UTCTime
utcTime TimeZoneSeries
tzSeries) = Context -> DucklingTime
referenceTime Context
context
      refTime :: TimeObject
refTime = TimeObject :: UTCTime -> Grain -> Maybe UTCTime -> TimeObject
TimeObject
        { start :: UTCTime
start = UTCTime
utcTime
        , grain :: Grain
grain = Grain
TG.Second
        , end :: Maybe UTCTime
end = Maybe UTCTime
forall a. Maybe a
Nothing
        }
      tc :: TimeContext
tc = TimeContext :: TimeObject
-> TimeZoneSeries -> TimeObject -> TimeObject -> TimeContext
TimeContext
        { refTime :: TimeObject
refTime = TimeObject
refTime
        , tzSeries :: TimeZoneSeries
tzSeries = TimeZoneSeries
tzSeries
        , maxTime :: TimeObject
maxTime = TimeObject -> Grain -> Integer -> TimeObject
timePlus TimeObject
refTime Grain
TG.Year Integer
2000
        , minTime :: TimeObject
minTime = TimeObject -> Grain -> Integer -> TimeObject
timePlus TimeObject
refTime Grain
TG.Year (Integer -> TimeObject) -> Integer -> TimeObject
forall a b. (a -> b) -> a -> b
$ - Integer
2000
        }
      ([TimeObject]
past, [TimeObject]
future) = Predicate -> SeriesPredicate
runPredicate Predicate
timePred TimeObject
refTime TimeContext
tc

timedata' :: TimeData
timedata' :: TimeData
timedata' = TimeData :: Predicate
-> Bool
-> Grain
-> Bool
-> Maybe Form
-> Maybe IntervalDirection
-> Bool
-> Maybe Text
-> Bool
-> TimeData
TimeData
  { timePred :: Predicate
timePred = Predicate
mkEmptyPredicate
  , latent :: Bool
latent = Bool
False
  , timeGrain :: Grain
timeGrain = Grain
TG.Second
  , notImmediate :: Bool
notImmediate = Bool
False
  , form :: Maybe Form
form = Maybe Form
forall a. Maybe a
Nothing
  , direction :: Maybe IntervalDirection
direction = Maybe IntervalDirection
forall a. Maybe a
Nothing
  , okForThisNext :: Bool
okForThisNext = Bool
False
  , holiday :: Maybe Text
holiday = Maybe Text
forall a. Maybe a
Nothing
  , hasTimezone :: Bool
hasTimezone = Bool
False
  }

data TimeContext = TimeContext
  { TimeContext -> TimeObject
refTime  :: TimeObject
  , TimeContext -> TimeZoneSeries
tzSeries :: Series.TimeZoneSeries
  , TimeContext -> TimeObject
maxTime  :: TimeObject
  , TimeContext -> TimeObject
minTime  :: TimeObject
  }

data InstantValue = InstantValue
  { InstantValue -> ZonedTime
vValue :: Time.ZonedTime
  , InstantValue -> Grain
vGrain :: Grain
  }
  deriving (Int -> InstantValue -> ShowS
[InstantValue] -> ShowS
InstantValue -> String
(Int -> InstantValue -> ShowS)
-> (InstantValue -> String)
-> ([InstantValue] -> ShowS)
-> Show InstantValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InstantValue] -> ShowS
$cshowList :: [InstantValue] -> ShowS
show :: InstantValue -> String
$cshow :: InstantValue -> String
showsPrec :: Int -> InstantValue -> ShowS
$cshowsPrec :: Int -> InstantValue -> ShowS
Show)

instance Eq InstantValue where
  == :: InstantValue -> InstantValue -> Bool
(==) (InstantValue (Time.ZonedTime LocalTime
lt1 TimeZone
tz1) Grain
g1)
       (InstantValue (Time.ZonedTime LocalTime
lt2 TimeZone
tz2) Grain
g2) =
    Grain
g1 Grain -> Grain -> Bool
forall a. Eq a => a -> a -> Bool
== Grain
g2 Bool -> Bool -> Bool
&& LocalTime
lt1 LocalTime -> LocalTime -> Bool
forall a. Eq a => a -> a -> Bool
== LocalTime
lt2 Bool -> Bool -> Bool
&& TimeZone
tz1 TimeZone -> TimeZone -> Bool
forall a. Eq a => a -> a -> Bool
== TimeZone
tz2

data SingleTimeValue
  = SimpleValue InstantValue
  | IntervalValue (InstantValue, InstantValue)
  | OpenIntervalValue (InstantValue, IntervalDirection)
  deriving (Int -> SingleTimeValue -> ShowS
[SingleTimeValue] -> ShowS
SingleTimeValue -> String
(Int -> SingleTimeValue -> ShowS)
-> (SingleTimeValue -> String)
-> ([SingleTimeValue] -> ShowS)
-> Show SingleTimeValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SingleTimeValue] -> ShowS
$cshowList :: [SingleTimeValue] -> ShowS
show :: SingleTimeValue -> String
$cshow :: SingleTimeValue -> String
showsPrec :: Int -> SingleTimeValue -> ShowS
$cshowsPrec :: Int -> SingleTimeValue -> ShowS
Show, SingleTimeValue -> SingleTimeValue -> Bool
(SingleTimeValue -> SingleTimeValue -> Bool)
-> (SingleTimeValue -> SingleTimeValue -> Bool)
-> Eq SingleTimeValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SingleTimeValue -> SingleTimeValue -> Bool
$c/= :: SingleTimeValue -> SingleTimeValue -> Bool
== :: SingleTimeValue -> SingleTimeValue -> Bool
$c== :: SingleTimeValue -> SingleTimeValue -> Bool
Eq)

data TimeValue = TimeValue SingleTimeValue [SingleTimeValue] (Maybe Text)
  deriving (Int -> TimeValue -> ShowS
[TimeValue] -> ShowS
TimeValue -> String
(Int -> TimeValue -> ShowS)
-> (TimeValue -> String)
-> ([TimeValue] -> ShowS)
-> Show TimeValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeValue] -> ShowS
$cshowList :: [TimeValue] -> ShowS
show :: TimeValue -> String
$cshow :: TimeValue -> String
showsPrec :: Int -> TimeValue -> ShowS
$cshowsPrec :: Int -> TimeValue -> ShowS
Show, TimeValue -> TimeValue -> Bool
(TimeValue -> TimeValue -> Bool)
-> (TimeValue -> TimeValue -> Bool) -> Eq TimeValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeValue -> TimeValue -> Bool
$c/= :: TimeValue -> TimeValue -> Bool
== :: TimeValue -> TimeValue -> Bool
$c== :: TimeValue -> TimeValue -> Bool
Eq)

instance ToJSON InstantValue where
  toJSON :: InstantValue -> Value
toJSON (InstantValue ZonedTime
value Grain
grain) = [Pair] -> Value
object
    [ Text
"value" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ZonedTime -> Text
toRFC3339 ZonedTime
value
    , Text
"grain" Text -> Grain -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Grain
grain
    ]

instance ToJSON SingleTimeValue where
  toJSON :: SingleTimeValue -> Value
toJSON (SimpleValue InstantValue
value) = case InstantValue -> Value
forall a. ToJSON a => a -> Value
toJSON InstantValue
value of
    Object Object
o -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert Text
"type" (Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"value" :: Text)) Object
o
    Value
_ -> Object -> Value
Object Object
forall k v. HashMap k v
H.empty
  toJSON (IntervalValue (InstantValue
from, InstantValue
to)) = [Pair] -> Value
object
    [ Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"interval" :: Text)
    , Text
"from" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= InstantValue -> Value
forall a. ToJSON a => a -> Value
toJSON InstantValue
from
    , Text
"to" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= InstantValue -> Value
forall a. ToJSON a => a -> Value
toJSON InstantValue
to
    ]
  toJSON (OpenIntervalValue (InstantValue
instant, IntervalDirection
Before)) = [Pair] -> Value
object
    [ Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"interval" :: Text)
    , Text
"to" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= InstantValue -> Value
forall a. ToJSON a => a -> Value
toJSON InstantValue
instant
    ]
  toJSON (OpenIntervalValue (InstantValue
instant, IntervalDirection
After)) = [Pair] -> Value
object
    [ Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"interval" :: Text)
    , Text
"from" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= InstantValue -> Value
forall a. ToJSON a => a -> Value
toJSON InstantValue
instant
    ]

instance ToJSON TimeValue where
  toJSON :: TimeValue -> Value
toJSON (TimeValue SingleTimeValue
value [SingleTimeValue]
values Maybe Text
holiday) = case SingleTimeValue -> Value
forall a. ToJSON a => a -> Value
toJSON SingleTimeValue
value of
    Object Object
o ->
      Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Object -> Object
insertHoliday Maybe Text
holiday (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert Text
"values" ([SingleTimeValue] -> Value
forall a. ToJSON a => a -> Value
toJSON [SingleTimeValue]
values) Object
o
    Value
_ -> Object -> Value
Object Object
forall k v. HashMap k v
H.empty
    where
      insertHoliday :: Maybe Text -> Object -> Object
      insertHoliday :: Maybe Text -> Object -> Object
insertHoliday Maybe Text
Nothing Object
obj = Object
obj
      insertHoliday (Just Text
h) Object
obj = Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert Text
"holidayBeta" (Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
h) Object
obj

-- | Return a tuple of (past, future) elements
type SeriesPredicate = TimeObject -> TimeContext -> ([TimeObject], [TimeObject])

data AMPM = AM | PM
  deriving (AMPM -> AMPM -> Bool
(AMPM -> AMPM -> Bool) -> (AMPM -> AMPM -> Bool) -> Eq AMPM
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AMPM -> AMPM -> Bool
$c/= :: AMPM -> AMPM -> Bool
== :: AMPM -> AMPM -> Bool
$c== :: AMPM -> AMPM -> Bool
Eq, Int -> AMPM -> ShowS
[AMPM] -> ShowS
AMPM -> String
(Int -> AMPM -> ShowS)
-> (AMPM -> String) -> ([AMPM] -> ShowS) -> Show AMPM
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AMPM] -> ShowS
$cshowList :: [AMPM] -> ShowS
show :: AMPM -> String
$cshow :: AMPM -> String
showsPrec :: Int -> AMPM -> ShowS
$cshowsPrec :: Int -> AMPM -> ShowS
Show)

data SeasonName = Spring | Summer | Fall | Winter deriving (Int -> SeasonName
SeasonName -> Int
SeasonName -> [SeasonName]
SeasonName -> SeasonName
SeasonName -> SeasonName -> [SeasonName]
SeasonName -> SeasonName -> SeasonName -> [SeasonName]
(SeasonName -> SeasonName)
-> (SeasonName -> SeasonName)
-> (Int -> SeasonName)
-> (SeasonName -> Int)
-> (SeasonName -> [SeasonName])
-> (SeasonName -> SeasonName -> [SeasonName])
-> (SeasonName -> SeasonName -> [SeasonName])
-> (SeasonName -> SeasonName -> SeasonName -> [SeasonName])
-> Enum SeasonName
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: SeasonName -> SeasonName -> SeasonName -> [SeasonName]
$cenumFromThenTo :: SeasonName -> SeasonName -> SeasonName -> [SeasonName]
enumFromTo :: SeasonName -> SeasonName -> [SeasonName]
$cenumFromTo :: SeasonName -> SeasonName -> [SeasonName]
enumFromThen :: SeasonName -> SeasonName -> [SeasonName]
$cenumFromThen :: SeasonName -> SeasonName -> [SeasonName]
enumFrom :: SeasonName -> [SeasonName]
$cenumFrom :: SeasonName -> [SeasonName]
fromEnum :: SeasonName -> Int
$cfromEnum :: SeasonName -> Int
toEnum :: Int -> SeasonName
$ctoEnum :: Int -> SeasonName
pred :: SeasonName -> SeasonName
$cpred :: SeasonName -> SeasonName
succ :: SeasonName -> SeasonName
$csucc :: SeasonName -> SeasonName
Enum,SeasonName -> SeasonName -> Bool
(SeasonName -> SeasonName -> Bool)
-> (SeasonName -> SeasonName -> Bool) -> Eq SeasonName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SeasonName -> SeasonName -> Bool
$c/= :: SeasonName -> SeasonName -> Bool
== :: SeasonName -> SeasonName -> Bool
$c== :: SeasonName -> SeasonName -> Bool
Eq,Eq SeasonName
Eq SeasonName
-> (SeasonName -> SeasonName -> Ordering)
-> (SeasonName -> SeasonName -> Bool)
-> (SeasonName -> SeasonName -> Bool)
-> (SeasonName -> SeasonName -> Bool)
-> (SeasonName -> SeasonName -> Bool)
-> (SeasonName -> SeasonName -> SeasonName)
-> (SeasonName -> SeasonName -> SeasonName)
-> Ord SeasonName
SeasonName -> SeasonName -> Bool
SeasonName -> SeasonName -> Ordering
SeasonName -> SeasonName -> SeasonName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SeasonName -> SeasonName -> SeasonName
$cmin :: SeasonName -> SeasonName -> SeasonName
max :: SeasonName -> SeasonName -> SeasonName
$cmax :: SeasonName -> SeasonName -> SeasonName
>= :: SeasonName -> SeasonName -> Bool
$c>= :: SeasonName -> SeasonName -> Bool
> :: SeasonName -> SeasonName -> Bool
$c> :: SeasonName -> SeasonName -> Bool
<= :: SeasonName -> SeasonName -> Bool
$c<= :: SeasonName -> SeasonName -> Bool
< :: SeasonName -> SeasonName -> Bool
$c< :: SeasonName -> SeasonName -> Bool
compare :: SeasonName -> SeasonName -> Ordering
$ccompare :: SeasonName -> SeasonName -> Ordering
$cp1Ord :: Eq SeasonName
Ord,Int -> SeasonName -> ShowS
[SeasonName] -> ShowS
SeasonName -> String
(Int -> SeasonName -> ShowS)
-> (SeasonName -> String)
-> ([SeasonName] -> ShowS)
-> Show SeasonName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SeasonName] -> ShowS
$cshowList :: [SeasonName] -> ShowS
show :: SeasonName -> String
$cshow :: SeasonName -> String
showsPrec :: Int -> SeasonName -> ShowS
$cshowsPrec :: Int -> SeasonName -> ShowS
Show)

-- | Regular seasons of the Northern Hemisphere.
data Season = Season { Season -> Integer
startYear :: Integer, Season -> SeasonName
seasonName :: SeasonName }
  deriving (Season -> Season -> Bool
(Season -> Season -> Bool)
-> (Season -> Season -> Bool) -> Eq Season
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Season -> Season -> Bool
$c/= :: Season -> Season -> Bool
== :: Season -> Season -> Bool
$c== :: Season -> Season -> Bool
Eq,Eq Season
Eq Season
-> (Season -> Season -> Ordering)
-> (Season -> Season -> Bool)
-> (Season -> Season -> Bool)
-> (Season -> Season -> Bool)
-> (Season -> Season -> Bool)
-> (Season -> Season -> Season)
-> (Season -> Season -> Season)
-> Ord Season
Season -> Season -> Bool
Season -> Season -> Ordering
Season -> Season -> Season
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Season -> Season -> Season
$cmin :: Season -> Season -> Season
max :: Season -> Season -> Season
$cmax :: Season -> Season -> Season
>= :: Season -> Season -> Bool
$c>= :: Season -> Season -> Bool
> :: Season -> Season -> Bool
$c> :: Season -> Season -> Bool
<= :: Season -> Season -> Bool
$c<= :: Season -> Season -> Bool
< :: Season -> Season -> Bool
$c< :: Season -> Season -> Bool
compare :: Season -> Season -> Ordering
$ccompare :: Season -> Season -> Ordering
$cp1Ord :: Eq Season
Ord,Int -> Season -> ShowS
[Season] -> ShowS
Season -> String
(Int -> Season -> ShowS)
-> (Season -> String) -> ([Season] -> ShowS) -> Show Season
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Season] -> ShowS
$cshowList :: [Season] -> ShowS
show :: Season -> String
$cshow :: Season -> String
showsPrec :: Int -> Season -> ShowS
$cshowsPrec :: Int -> Season -> ShowS
Show)

newtype NoShow a = NoShow a

instance Show (NoShow a) where
  show :: NoShow a -> String
show NoShow a
_ = String
"??"

data Predicate
  = SeriesPredicate (NoShow SeriesPredicate)
  | EmptyPredicate
  | TimeDatePredicate -- invariant: at least one of them is Just
    { Predicate -> Maybe Int
tdSecond :: Maybe Int
    , Predicate -> Maybe Int
tdMinute :: Maybe Int
    , Predicate -> Maybe (Bool, Int)
tdHour :: Maybe (Bool, Int)
    , Predicate -> Maybe AMPM
tdAMPM :: Maybe AMPM -- only used if we have an hour
    , Predicate -> Maybe Int
tdDayOfTheWeek :: Maybe Int
    , Predicate -> Maybe Int
tdDayOfTheMonth :: Maybe Int
    , Predicate -> Maybe Int
tdMonth :: Maybe Int
    , Predicate -> Maybe Int
tdYear :: Maybe Int
    }
  | IntersectPredicate Predicate Predicate
  | TimeIntervalsPredicate TimeIntervalType Predicate Predicate
  | ReplaceIntersectPredicate Predicate Predicate Predicate
  deriving Int -> Predicate -> ShowS
[Predicate] -> ShowS
Predicate -> String
(Int -> Predicate -> ShowS)
-> (Predicate -> String)
-> ([Predicate] -> ShowS)
-> Show Predicate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Predicate] -> ShowS
$cshowList :: [Predicate] -> ShowS
show :: Predicate -> String
$cshow :: Predicate -> String
showsPrec :: Int -> Predicate -> ShowS
$cshowsPrec :: Int -> Predicate -> ShowS
Show

runPredicate :: Predicate -> SeriesPredicate
runPredicate :: Predicate -> SeriesPredicate
runPredicate EmptyPredicate{} = \TimeObject
_ TimeContext
_ -> ([], [])
runPredicate (SeriesPredicate (NoShow SeriesPredicate
p)) = SeriesPredicate
p
runPredicate TimeDatePredicate{Maybe Int
Maybe (Bool, Int)
Maybe AMPM
tdYear :: Maybe Int
tdMonth :: Maybe Int
tdDayOfTheMonth :: Maybe Int
tdDayOfTheWeek :: Maybe Int
tdAMPM :: Maybe AMPM
tdHour :: Maybe (Bool, Int)
tdMinute :: Maybe Int
tdSecond :: Maybe Int
tdYear :: Predicate -> Maybe Int
tdMonth :: Predicate -> Maybe Int
tdDayOfTheMonth :: Predicate -> Maybe Int
tdDayOfTheWeek :: Predicate -> Maybe Int
tdAMPM :: Predicate -> Maybe AMPM
tdHour :: Predicate -> Maybe (Bool, Int)
tdMinute :: Predicate -> Maybe Int
tdSecond :: Predicate -> Maybe Int
..}
  -- This should not happen by construction, but if it does then
  -- empty time series should be ok
  | Maybe (Bool, Int) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Bool, Int)
tdHour Bool -> Bool -> Bool
&& Maybe AMPM -> Bool
forall a. Maybe a -> Bool
isJust Maybe AMPM
tdAMPM = \TimeObject
_ TimeContext
_ -> ([], [])
runPredicate TimeDatePredicate{Maybe Int
Maybe (Bool, Int)
Maybe AMPM
tdYear :: Maybe Int
tdMonth :: Maybe Int
tdDayOfTheMonth :: Maybe Int
tdDayOfTheWeek :: Maybe Int
tdAMPM :: Maybe AMPM
tdHour :: Maybe (Bool, Int)
tdMinute :: Maybe Int
tdSecond :: Maybe Int
tdYear :: Predicate -> Maybe Int
tdMonth :: Predicate -> Maybe Int
tdDayOfTheMonth :: Predicate -> Maybe Int
tdDayOfTheWeek :: Predicate -> Maybe Int
tdAMPM :: Predicate -> Maybe AMPM
tdHour :: Predicate -> Maybe (Bool, Int)
tdMinute :: Predicate -> Maybe Int
tdSecond :: Predicate -> Maybe Int
..} =
  (SeriesPredicate -> SeriesPredicate -> SeriesPredicate)
-> [SeriesPredicate] -> SeriesPredicate
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 SeriesPredicate -> SeriesPredicate -> SeriesPredicate
runCompose [SeriesPredicate]
toCompose
  where
  -- runComposePredicate performs best when the first predicate is of
  -- smaller grain, that's why we order by grain here
  toCompose :: [SeriesPredicate]
toCompose = [Maybe SeriesPredicate] -> [SeriesPredicate]
forall a. [Maybe a] -> [a]
catMaybes
    [ Int -> SeriesPredicate
runSecondPredicate (Int -> SeriesPredicate) -> Maybe Int -> Maybe SeriesPredicate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
tdSecond
    , Int -> SeriesPredicate
runMinutePredicate (Int -> SeriesPredicate) -> Maybe Int -> Maybe SeriesPredicate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
tdMinute
    , (Bool -> Int -> SeriesPredicate) -> (Bool, Int) -> SeriesPredicate
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Maybe AMPM -> Bool -> Int -> SeriesPredicate
runHourPredicate Maybe AMPM
tdAMPM) ((Bool, Int) -> SeriesPredicate)
-> Maybe (Bool, Int) -> Maybe SeriesPredicate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Bool, Int)
tdHour
    , Int -> SeriesPredicate
runDayOfTheWeekPredicate (Int -> SeriesPredicate) -> Maybe Int -> Maybe SeriesPredicate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
tdDayOfTheWeek
    , Int -> SeriesPredicate
runDayOfTheMonthPredicate (Int -> SeriesPredicate) -> Maybe Int -> Maybe SeriesPredicate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
tdDayOfTheMonth
    , Int -> SeriesPredicate
runMonthPredicate (Int -> SeriesPredicate) -> Maybe Int -> Maybe SeriesPredicate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
tdMonth
    , Int -> SeriesPredicate
runYearPredicate (Int -> SeriesPredicate) -> Maybe Int -> Maybe SeriesPredicate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
tdYear
    ]
runPredicate (IntersectPredicate Predicate
pred1 Predicate
pred2) =
  Predicate -> Predicate -> SeriesPredicate
runIntersectPredicate Predicate
pred1 Predicate
pred2
runPredicate (TimeIntervalsPredicate TimeIntervalType
ty Predicate
pred1 Predicate
pred2) =
  TimeIntervalType -> Predicate -> Predicate -> SeriesPredicate
runTimeIntervalsPredicate TimeIntervalType
ty Predicate
pred1 Predicate
pred2
runPredicate (ReplaceIntersectPredicate Predicate
pred1 Predicate
pred2 Predicate
pred3) =
  Predicate -> Predicate -> Predicate -> SeriesPredicate
runReplaceIntersectPredicate Predicate
pred1 Predicate
pred2 Predicate
pred3

-- Don't use outside this module, use a smart constructor
emptyTimeDatePredicate :: Predicate
emptyTimeDatePredicate :: Predicate
emptyTimeDatePredicate =
  Maybe Int
-> Maybe Int
-> Maybe (Bool, Int)
-> Maybe AMPM
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Predicate
TimeDatePredicate Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing Maybe (Bool, Int)
forall a. Maybe a
Nothing Maybe AMPM
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing
    Maybe Int
forall a. Maybe a
Nothing

-- Predicate smart constructors

-- For debugging find it useful to make it:
-- mkEmptyPredicate :: HasCallStack => Predicate
-- mkEmptyPredicate = EmptyPredicate callStack
-- This way I can track where EmptyPredicates get created
mkEmptyPredicate :: Predicate
mkEmptyPredicate :: Predicate
mkEmptyPredicate = Predicate
EmptyPredicate

mkSeriesPredicate :: SeriesPredicate -> Predicate
mkSeriesPredicate :: SeriesPredicate -> Predicate
mkSeriesPredicate = NoShow SeriesPredicate -> Predicate
SeriesPredicate (NoShow SeriesPredicate -> Predicate)
-> (SeriesPredicate -> NoShow SeriesPredicate)
-> SeriesPredicate
-> Predicate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SeriesPredicate -> NoShow SeriesPredicate
forall a. a -> NoShow a
NoShow

mkSecondPredicate :: Int -> Predicate
mkSecondPredicate :: Int -> Predicate
mkSecondPredicate Int
n = Predicate
emptyTimeDatePredicate { tdSecond :: Maybe Int
tdSecond = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n }

mkMinutePredicate :: Int -> Predicate
mkMinutePredicate :: Int -> Predicate
mkMinutePredicate Int
n = Predicate
emptyTimeDatePredicate { tdMinute :: Maybe Int
tdMinute = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n }

mkHourPredicate :: Bool -> Int -> Predicate
mkHourPredicate :: Bool -> Int -> Predicate
mkHourPredicate Bool
is12H Int
h = Predicate
emptyTimeDatePredicate { tdHour :: Maybe (Bool, Int)
tdHour = (Bool, Int) -> Maybe (Bool, Int)
forall a. a -> Maybe a
Just (Bool
is12H, Int
h) }

mkAMPMPredicate :: AMPM -> Predicate
mkAMPMPredicate :: AMPM -> Predicate
mkAMPMPredicate AMPM
ampm = Predicate
emptyTimeDatePredicate { tdAMPM :: Maybe AMPM
tdAMPM = AMPM -> Maybe AMPM
forall a. a -> Maybe a
Just AMPM
ampm }

mkDayOfTheWeekPredicate :: Int -> Predicate
mkDayOfTheWeekPredicate :: Int -> Predicate
mkDayOfTheWeekPredicate Int
n = Predicate
emptyTimeDatePredicate { tdDayOfTheWeek :: Maybe Int
tdDayOfTheWeek = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n }

mkDayOfTheMonthPredicate :: Int -> Predicate
mkDayOfTheMonthPredicate :: Int -> Predicate
mkDayOfTheMonthPredicate Int
n = Predicate
emptyTimeDatePredicate { tdDayOfTheMonth :: Maybe Int
tdDayOfTheMonth = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n }

mkMonthPredicate :: Int -> Predicate
mkMonthPredicate :: Int -> Predicate
mkMonthPredicate Int
n = Predicate
emptyTimeDatePredicate { tdMonth :: Maybe Int
tdMonth = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n }

mkYearPredicate :: Int -> Predicate
mkYearPredicate :: Int -> Predicate
mkYearPredicate Int
n = Predicate
emptyTimeDatePredicate { tdYear :: Maybe Int
tdYear = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n }

mkIntersectPredicate :: Predicate -> Predicate -> Predicate
mkIntersectPredicate :: Predicate -> Predicate -> Predicate
mkIntersectPredicate a :: Predicate
a@EmptyPredicate{} Predicate
_ = Predicate
a
mkIntersectPredicate Predicate
_ a :: Predicate
a@EmptyPredicate{} = Predicate
a
mkIntersectPredicate
  (TimeDatePredicate Maybe Int
a1 Maybe Int
b1 Maybe (Bool, Int)
c1 Maybe AMPM
d1 Maybe Int
e1 Maybe Int
f1 Maybe Int
g1 Maybe Int
h1)
  (TimeDatePredicate Maybe Int
a2 Maybe Int
b2 Maybe (Bool, Int)
c2 Maybe AMPM
d2 Maybe Int
e2 Maybe Int
f2 Maybe Int
g2 Maybe Int
h2)
  = Predicate -> Maybe Predicate -> Predicate
forall a. a -> Maybe a -> a
fromMaybe Predicate
mkEmptyPredicate
      (Maybe Int
-> Maybe Int
-> Maybe (Bool, Int)
-> Maybe AMPM
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Predicate
TimeDatePredicate (Maybe Int
 -> Maybe Int
 -> Maybe (Bool, Int)
 -> Maybe AMPM
 -> Maybe Int
 -> Maybe Int
 -> Maybe Int
 -> Maybe Int
 -> Predicate)
-> Maybe (Maybe Int)
-> Maybe
     (Maybe Int
      -> Maybe (Bool, Int)
      -> Maybe AMPM
      -> Maybe Int
      -> Maybe Int
      -> Maybe Int
      -> Maybe Int
      -> Predicate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Maybe Int -> Maybe Int -> Maybe (Maybe Int)
forall a. Eq a => Maybe a -> Maybe a -> Maybe (Maybe a)
unify Maybe Int
a1 Maybe Int
a2 Maybe
  (Maybe Int
   -> Maybe (Bool, Int)
   -> Maybe AMPM
   -> Maybe Int
   -> Maybe Int
   -> Maybe Int
   -> Maybe Int
   -> Predicate)
-> Maybe (Maybe Int)
-> Maybe
     (Maybe (Bool, Int)
      -> Maybe AMPM
      -> Maybe Int
      -> Maybe Int
      -> Maybe Int
      -> Maybe Int
      -> Predicate)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        Maybe Int -> Maybe Int -> Maybe (Maybe Int)
forall a. Eq a => Maybe a -> Maybe a -> Maybe (Maybe a)
unify Maybe Int
b1 Maybe Int
b2 Maybe
  (Maybe (Bool, Int)
   -> Maybe AMPM
   -> Maybe Int
   -> Maybe Int
   -> Maybe Int
   -> Maybe Int
   -> Predicate)
-> Maybe (Maybe (Bool, Int))
-> Maybe
     (Maybe AMPM
      -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Predicate)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        Maybe (Bool, Int) -> Maybe (Bool, Int) -> Maybe (Maybe (Bool, Int))
forall a. Eq a => Maybe a -> Maybe a -> Maybe (Maybe a)
unify Maybe (Bool, Int)
c1 Maybe (Bool, Int)
c2 Maybe
  (Maybe AMPM
   -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Predicate)
-> Maybe (Maybe AMPM)
-> Maybe
     (Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Predicate)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        Maybe AMPM -> Maybe AMPM -> Maybe (Maybe AMPM)
forall a. Eq a => Maybe a -> Maybe a -> Maybe (Maybe a)
unify Maybe AMPM
d1 Maybe AMPM
d2 Maybe
  (Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Predicate)
-> Maybe (Maybe Int)
-> Maybe (Maybe Int -> Maybe Int -> Maybe Int -> Predicate)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        Maybe Int -> Maybe Int -> Maybe (Maybe Int)
forall a. Eq a => Maybe a -> Maybe a -> Maybe (Maybe a)
unify Maybe Int
e1 Maybe Int
e2 Maybe (Maybe Int -> Maybe Int -> Maybe Int -> Predicate)
-> Maybe (Maybe Int) -> Maybe (Maybe Int -> Maybe Int -> Predicate)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        Maybe Int -> Maybe Int -> Maybe (Maybe Int)
forall a. Eq a => Maybe a -> Maybe a -> Maybe (Maybe a)
unify Maybe Int
f1 Maybe Int
f2 Maybe (Maybe Int -> Maybe Int -> Predicate)
-> Maybe (Maybe Int) -> Maybe (Maybe Int -> Predicate)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        Maybe Int -> Maybe Int -> Maybe (Maybe Int)
forall a. Eq a => Maybe a -> Maybe a -> Maybe (Maybe a)
unify Maybe Int
g1 Maybe Int
g2 Maybe (Maybe Int -> Predicate)
-> Maybe (Maybe Int) -> Maybe Predicate
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        Maybe Int -> Maybe Int -> Maybe (Maybe Int)
forall a. Eq a => Maybe a -> Maybe a -> Maybe (Maybe a)
unify Maybe Int
h1 Maybe Int
h2)
  where
  unify :: Maybe a -> Maybe a -> Maybe (Maybe a)
unify Maybe a
Nothing Maybe a
a = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
a
  unify Maybe a
a Maybe a
Nothing = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
a
  unify ma :: Maybe a
ma@(Just a
a) (Just a
b)
    | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
ma
    | Bool
otherwise = Maybe (Maybe a)
forall a. Maybe a
Nothing
mkIntersectPredicate Predicate
pred1 Predicate
pred2 = Predicate -> Predicate -> Predicate
IntersectPredicate Predicate
pred1 Predicate
pred2

mkReplaceIntersectPredicate :: Predicate -> Predicate -> Predicate -> Predicate
mkReplaceIntersectPredicate :: Predicate -> Predicate -> Predicate -> Predicate
mkReplaceIntersectPredicate Predicate
pred1 Predicate
pred2 Predicate
pred3 =
  Predicate -> Predicate -> Predicate -> Predicate
ReplaceIntersectPredicate Predicate
pred1 Predicate
pred2 Predicate
pred3

mkTimeIntervalsPredicate
  :: TimeIntervalType -> Predicate -> Predicate -> Predicate
mkTimeIntervalsPredicate :: TimeIntervalType -> Predicate -> Predicate -> Predicate
mkTimeIntervalsPredicate TimeIntervalType
_ a :: Predicate
a@EmptyPredicate{} Predicate
_ = Predicate
a
mkTimeIntervalsPredicate TimeIntervalType
_ Predicate
_ a :: Predicate
a@EmptyPredicate{} = Predicate
a
-- `from (... from a to b ...) to c` and `from c to (... from a to b ...)` don't
-- really have a good interpretation, so abort early
mkTimeIntervalsPredicate TimeIntervalType
_ Predicate
a Predicate
b
  | Predicate -> Bool
containsTimeIntervalsPredicate Predicate
a Bool -> Bool -> Bool
||
    Predicate -> Bool
containsTimeIntervalsPredicate Predicate
b = Predicate
mkEmptyPredicate
  -- this is potentially quadratic, but the sizes involved should be small
mkTimeIntervalsPredicate TimeIntervalType
t Predicate
a Predicate
b = TimeIntervalType -> Predicate -> Predicate -> Predicate
TimeIntervalsPredicate TimeIntervalType
t Predicate
a Predicate
b

containsTimeIntervalsPredicate :: Predicate -> Bool
containsTimeIntervalsPredicate :: Predicate -> Bool
containsTimeIntervalsPredicate TimeIntervalsPredicate{} = Bool
True
containsTimeIntervalsPredicate (IntersectPredicate Predicate
a Predicate
b) =
  Predicate -> Bool
containsTimeIntervalsPredicate Predicate
a Bool -> Bool -> Bool
|| Predicate -> Bool
containsTimeIntervalsPredicate Predicate
b
containsTimeIntervalsPredicate Predicate
_ = Bool
False
  -- SeriesPredicate might contain one, but we'll underapproximate for
  -- now

-- Computes the difference of the start time of two `TimeObject`s.
diffStartTime :: TimeObject -> TimeObject -> Time.NominalDiffTime
diffStartTime :: TimeObject -> TimeObject -> NominalDiffTime
diffStartTime TimeObject{start :: TimeObject -> UTCTime
start = UTCTime
x} TimeObject{start :: TimeObject -> UTCTime
start = UTCTime
y} =
  NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
abs (UTCTime -> UTCTime -> NominalDiffTime
Time.diffUTCTime UTCTime
x UTCTime
y)

isEmptyPredicate :: Predicate -> Bool
isEmptyPredicate :: Predicate -> Bool
isEmptyPredicate EmptyPredicate{} = Bool
True
isEmptyPredicate Predicate
_ = Bool
False

seasonStart :: Season -> Time.Day
seasonStart :: Season -> Day
seasonStart (Season Integer
year SeasonName
Spring) = Integer -> Int -> Int -> Day
Time.fromGregorian Integer
year Int
3 Int
20
seasonStart (Season Integer
year SeasonName
Summer) = Integer -> Int -> Int -> Day
Time.fromGregorian Integer
year Int
6 Int
21
seasonStart (Season Integer
year SeasonName
Fall) = Integer -> Int -> Int -> Day
Time.fromGregorian Integer
year Int
9 Int
23
seasonStart (Season Integer
year SeasonName
Winter) = Integer -> Int -> Int -> Day
Time.fromGregorian Integer
year Int
12 Int
21

seasonEnd :: Season -> Time.Day
seasonEnd :: Season -> Day
seasonEnd = Integer -> Day -> Day
Time.addDays (-Integer
1) (Day -> Day) -> (Season -> Day) -> Season -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Season -> Day
seasonStart (Season -> Day) -> (Season -> Season) -> Season -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Season -> Season
nextSeason

nextSeason :: Season -> Season
nextSeason :: Season -> Season
nextSeason (Season Integer
year SeasonName
Winter) = Integer -> SeasonName -> Season
Season (Integer
yearInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) SeasonName
Spring
nextSeason (Season Integer
year SeasonName
x) = Integer -> SeasonName -> Season
Season Integer
year (SeasonName -> SeasonName
forall a. Enum a => a -> a
succ SeasonName
x)

prevSeason :: Season -> Season
prevSeason :: Season -> Season
prevSeason (Season Integer
year SeasonName
Spring) = Integer -> SeasonName -> Season
Season (Integer
yearInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) SeasonName
Winter
prevSeason (Season Integer
year SeasonName
x) = Integer -> SeasonName -> Season
Season Integer
year (SeasonName -> SeasonName
forall a. Enum a => a -> a
pred SeasonName
x)

seasonOf :: Time.Day -> Season
seasonOf :: Day -> Season
seasonOf Day
day = Season -> Maybe Season -> Season
forall a. a -> Maybe a -> a
fromMaybe (Integer -> SeasonName -> Season
Season (Integer
yearInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) SeasonName
Winter) Maybe Season
mbSeason
  where
  (Integer
year,Int
_,Int
_) = Day -> (Integer, Int, Int)
Time.toGregorian Day
day
  mbSeason :: Maybe Season
mbSeason = (Season -> Bool) -> [Season] -> Maybe Season
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
<= Day
day) (Day -> Bool) -> (Season -> Day) -> Season -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Season -> Day
seasonStart) ([Season] -> Maybe Season) -> [Season] -> Maybe Season
forall a b. (a -> b) -> a -> b
$
               Integer -> SeasonName -> Season
Season Integer
year (SeasonName -> Season) -> [SeasonName] -> [Season]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SeasonName
Winter,SeasonName
Fall,SeasonName
Summer,SeasonName
Spring]

seasonPredicate :: Predicate
seasonPredicate :: Predicate
seasonPredicate = SeriesPredicate -> Predicate
mkSeriesPredicate SeriesPredicate
forall b. TimeObject -> b -> ([TimeObject], [TimeObject])
series
  where
  series :: TimeObject -> b -> ([TimeObject], [TimeObject])
series TimeObject
t = ([TimeObject], [TimeObject]) -> b -> ([TimeObject], [TimeObject])
forall a b. a -> b -> a
const ([TimeObject]
past,[TimeObject]
future)
    where
    day :: Day
day = UTCTime -> Day
Time.utctDay (TimeObject -> UTCTime
start TimeObject
t)
    ([TimeObject]
past,[TimeObject]
future) = ([Season] -> [TimeObject])
-> ([Season], [Season]) -> ([TimeObject], [TimeObject])
forall a b. (a -> b) -> (a, a) -> (b, b)
both ((Season -> TimeObject) -> [Season] -> [TimeObject]
forall a b. (a -> b) -> [a] -> [b]
map Season -> TimeObject
toTimeObj) (Day -> ([Season], [Season])
toZipper Day
day)
    toTimeObj :: Season -> TimeObject
toTimeObj Season
season = TimeObject :: UTCTime -> Grain -> Maybe UTCTime -> TimeObject
TimeObject { start :: UTCTime
start = UTCTime
s, grain :: Grain
grain = Grain
TG.Day, end :: Maybe UTCTime
end = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
e }
      where (UTCTime
s,UTCTime
e) = (Day -> UTCTime) -> (Day, Day) -> (UTCTime, UTCTime)
forall a b. (a -> b) -> (a, a) -> (b, b)
both Day -> UTCTime
toMidnight (Season -> Day
seasonStart Season
season, Season -> Day
seasonEnd Season
season)
    toZipper :: Day -> ([Season], [Season])
toZipper Day
d = ([Season]
before, [Season]
currentAndAfter)
      where
      current :: Season
current = Day -> Season
seasonOf Day
d
      currentAndAfter :: [Season]
currentAndAfter = (Season -> Season) -> Season -> [Season]
forall a. (a -> a) -> a -> [a]
iterate Season -> Season
nextSeason Season
current
      before :: [Season]
before = (Season -> Season) -> Season -> [Season]
forall a. (a -> a) -> a -> [a]
iterate Season -> Season
prevSeason (Season -> Season
prevSeason Season
current)

-- Predicate for weekdays, i.e., Mon to Fri.
weekdayPredicate :: Predicate
weekdayPredicate :: Predicate
weekdayPredicate = SeriesPredicate -> Predicate
mkSeriesPredicate SeriesPredicate
forall b. TimeObject -> b -> ([TimeObject], [TimeObject])
series
  where
  series :: TimeObject -> b -> ([TimeObject], [TimeObject])
series TimeObject
t = ([TimeObject], [TimeObject]) -> b -> ([TimeObject], [TimeObject])
forall a b. a -> b -> a
const ([TimeObject]
past,[TimeObject]
future)
    where
    day :: Day
day = UTCTime -> Day
Time.utctDay (TimeObject -> UTCTime
start TimeObject
t)
    (Integer
_,Int
_,Int
dayOfWeek) = Day -> (Integer, Int, Int)
Time.toWeekDate Day
day
    past :: [TimeObject]
past = UTCTime -> TimeObject
toTimeObj (UTCTime -> TimeObject)
-> ((Day, Int) -> UTCTime) -> (Day, Int) -> TimeObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> UTCTime
toMidnight (Day -> UTCTime) -> ((Day, Int) -> Day) -> (Day, Int) -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Day, Int) -> Day
forall a b. (a, b) -> a
fst ((Day, Int) -> TimeObject) -> [(Day, Int)] -> [TimeObject]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      ((Day, Int) -> (Day, Int)) -> (Day, Int) -> [(Day, Int)]
forall a. (a -> a) -> a -> [a]
iterate (Day, Int) -> (Day, Int)
forall b. (Eq b, Num b) => (Day, b) -> (Day, b)
prevWeekday ((Day, Int) -> (Day, Int)
forall b. (Eq b, Num b) => (Day, b) -> (Day, b)
prevWeekday (Day
day,Int
dayOfWeek))
    future :: [TimeObject]
future = UTCTime -> TimeObject
toTimeObj (UTCTime -> TimeObject) -> (Day -> UTCTime) -> Day -> TimeObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> UTCTime
toMidnight (Day -> TimeObject) -> [Day] -> [TimeObject]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      if Int
dayOfWeek Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
5 then Day
dayDay -> [Day] -> [Day]
forall a. a -> [a] -> [a]
:[Day]
days else [Day]
days
        where days :: [Day]
days = (Day, Int) -> Day
forall a b. (a, b) -> a
fst ((Day, Int) -> Day) -> [(Day, Int)] -> [Day]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Day, Int) -> (Day, Int)) -> (Day, Int) -> [(Day, Int)]
forall a. (a -> a) -> a -> [a]
iterate (Day, Int) -> (Day, Int)
forall a. Integral a => (Day, a) -> (Day, a)
nextWeekday ((Day, Int) -> (Day, Int)
forall a. Integral a => (Day, a) -> (Day, a)
nextWeekday (Day
day,Int
dayOfWeek))
    toTimeObj :: UTCTime -> TimeObject
toTimeObj UTCTime
t = TimeObject :: UTCTime -> Grain -> Maybe UTCTime -> TimeObject
TimeObject { start :: UTCTime
start = UTCTime
t, grain :: Grain
grain = Grain
TG.Day, end :: Maybe UTCTime
end = Maybe UTCTime
forall a. Maybe a
Nothing }
    nextWeekday :: (Day, a) -> (Day, a)
nextWeekday (Day
d,a
dow)
      | a
dow a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
5 = (Integer -> Day -> Day
Time.addDays Integer
1 Day
d, a
dowa -> a -> a
forall a. Num a => a -> a -> a
+a
1)
      | Bool
otherwise = (Integer -> Day -> Day
Time.addDays (a -> Integer
forall a. Integral a => a -> Integer
toInteger (a -> Integer) -> a -> Integer
forall a b. (a -> b) -> a -> b
$ a
8a -> a -> a
forall a. Num a => a -> a -> a
-a
dow) Day
d, a
1)
    prevWeekday :: (Day, b) -> (Day, b)
prevWeekday (Day
d,b
dow)
      | b
dow b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
1 = (Integer -> Day -> Day
Time.addDays (-Integer
3) Day
d, b
5)
      | b
dow b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
7 = (Integer -> Day -> Day
Time.addDays (-Integer
2) Day
d, b
5)
      | Bool
otherwise = (Integer -> Day -> Day
Time.addDays (-Integer
1) Day
d, b
dowb -> b -> b
forall a. Num a => a -> a -> a
-b
1)

-- Predicate for periodic events with known `given`
periodicPredicate :: TG.Grain -> Int -> TimeObject -> Predicate
periodicPredicate :: Grain -> Int -> TimeObject -> Predicate
periodicPredicate Grain
grain Int
delta TimeObject
given = SeriesPredicate -> Predicate
mkSeriesPredicate SeriesPredicate
series
  where
  series :: SeriesPredicate
series TimeObject
t TimeContext
_ = ([TimeObject]
past', [TimeObject]
future')
    where
    ([TimeObject]
past, [TimeObject]
future) = Grain -> Int -> TimeObject -> ([TimeObject], [TimeObject])
timeSequence Grain
grain Int
delta TimeObject
given
    ([TimeObject]
past', [TimeObject]
future') = if TimeObject -> TimeObject -> Bool
timeBefore TimeObject
t TimeObject
given
      then
        let ([TimeObject]
newer, [TimeObject]
older) = (TimeObject -> Bool)
-> [TimeObject] -> ([TimeObject], [TimeObject])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (TimeObject -> TimeObject -> Bool
timeBefore TimeObject
t) [TimeObject]
past
        in ([TimeObject]
older, [TimeObject] -> [TimeObject]
forall a. [a] -> [a]
reverse [TimeObject]
newer [TimeObject] -> [TimeObject] -> [TimeObject]
forall a. [a] -> [a] -> [a]
++ [TimeObject]
future)
      else
        let ([TimeObject]
older, [TimeObject]
newer) = (TimeObject -> Bool)
-> [TimeObject] -> ([TimeObject], [TimeObject])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (TimeObject -> TimeObject -> Bool
`timeBefore` TimeObject
t) [TimeObject]
future
        in ([TimeObject] -> [TimeObject]
forall a. [a] -> [a]
reverse [TimeObject]
older [TimeObject] -> [TimeObject] -> [TimeObject]
forall a. [a] -> [a] -> [a]
++ [TimeObject]
past, [TimeObject]
newer)

toMidnight :: Time.Day -> Time.UTCTime
toMidnight :: Day -> UTCTime
toMidnight = (Day -> DiffTime -> UTCTime) -> DiffTime -> Day -> UTCTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip Day -> DiffTime -> UTCTime
Time.UTCTime (TimeOfDay -> DiffTime
Time.timeOfDayToTime TimeOfDay
Time.midnight)

-- Predicate runners

runSecondPredicate :: Int -> SeriesPredicate
runSecondPredicate :: Int -> SeriesPredicate
runSecondPredicate Int
n = SeriesPredicate
series
  where
  series :: SeriesPredicate
series TimeObject
t TimeContext
_ = Grain -> Int -> TimeObject -> ([TimeObject], [TimeObject])
timeSequence Grain
TG.Minute Int
1 TimeObject
anchor
    where
      Time.UTCTime Day
_ DiffTime
diffTime = TimeObject -> UTCTime
start TimeObject
t
      Time.TimeOfDay Int
_ Int
_ Pico
s = DiffTime -> TimeOfDay
Time.timeToTimeOfDay DiffTime
diffTime
      anchor :: TimeObject
anchor = TimeObject -> Grain -> Integer -> TimeObject
timePlus (TimeObject -> Grain -> TimeObject
timeRound TimeObject
t Grain
TG.Second) Grain
TG.Second
        (Integer -> TimeObject) -> Integer -> TimeObject
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Pico -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor Pico
s :: Integer) Integer
60

runMinutePredicate :: Int -> SeriesPredicate
runMinutePredicate :: Int -> SeriesPredicate
runMinutePredicate Int
n = SeriesPredicate
series
  where
  series :: SeriesPredicate
series TimeObject
t TimeContext
_ = Grain -> Int -> TimeObject -> ([TimeObject], [TimeObject])
timeSequence Grain
TG.Hour Int
1 TimeObject
anchor
    where
      Time.UTCTime Day
_ DiffTime
diffTime = TimeObject -> UTCTime
start TimeObject
t
      Time.TimeOfDay Int
_ Int
m Pico
_ = DiffTime -> TimeOfDay
Time.timeToTimeOfDay DiffTime
diffTime
      rounded :: TimeObject
rounded = TimeObject -> Grain -> TimeObject
timeRound TimeObject
t Grain
TG.Minute
      anchor :: TimeObject
anchor = TimeObject -> Grain -> Integer -> TimeObject
timePlus TimeObject
rounded Grain
TG.Minute (Integer -> TimeObject) -> (Int -> Integer) -> Int -> TimeObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> TimeObject) -> Int -> TimeObject
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m) Int
60

runHourPredicate :: Maybe AMPM -> Bool -> Int -> SeriesPredicate
runHourPredicate :: Maybe AMPM -> Bool -> Int -> SeriesPredicate
runHourPredicate Maybe AMPM
ampm Bool
is12H Int
n = SeriesPredicate
series
  where
  series :: SeriesPredicate
series TimeObject
t TimeContext
_ =
    ( Int -> [TimeObject] -> [TimeObject]
forall a. Int -> [a] -> [a]
drop Int
1 ([TimeObject] -> [TimeObject]) -> [TimeObject] -> [TimeObject]
forall a b. (a -> b) -> a -> b
$
        (TimeObject -> TimeObject) -> TimeObject -> [TimeObject]
forall a. (a -> a) -> a -> [a]
iterate (\TimeObject
t -> TimeObject -> Grain -> Integer -> TimeObject
timePlus TimeObject
t Grain
TG.Hour (Integer -> TimeObject) -> (Int -> Integer) -> Int -> TimeObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> TimeObject) -> Int -> TimeObject
forall a b. (a -> b) -> a -> b
$ - Int
step) TimeObject
anchor
    , (TimeObject -> TimeObject) -> TimeObject -> [TimeObject]
forall a. (a -> a) -> a -> [a]
iterate (\TimeObject
t -> TimeObject -> Grain -> Integer -> TimeObject
timePlus TimeObject
t Grain
TG.Hour (Integer -> TimeObject) -> Integer -> TimeObject
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
step) TimeObject
anchor
    )
    where
      Time.UTCTime Day
_ DiffTime
diffTime = TimeObject -> UTCTime
start TimeObject
t
      Time.TimeOfDay Int
h Int
_ Pico
_ = DiffTime -> TimeOfDay
Time.timeToTimeOfDay DiffTime
diffTime
      step :: Int
      step :: Int
step = if Bool
is12H Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
12 Bool -> Bool -> Bool
&& Maybe AMPM -> Bool
forall a. Maybe a -> Bool
isNothing Maybe AMPM
ampm then Int
12 else Int
24
      n' :: Int
n' = case Maybe AMPM
ampm of
            Just AMPM
AM -> Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
            Just AMPM
PM -> (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
12
            Maybe AMPM
Nothing -> Int
n
      rounded :: TimeObject
rounded = TimeObject -> Grain -> TimeObject
timeRound TimeObject
t Grain
TG.Hour
      anchor :: TimeObject
anchor = TimeObject -> Grain -> Integer -> TimeObject
timePlus TimeObject
rounded Grain
TG.Hour (Integer -> TimeObject) -> (Int -> Integer) -> Int -> TimeObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> TimeObject) -> Int -> TimeObject
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod (Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
h) Int
step

runAMPMPredicate :: AMPM -> SeriesPredicate
runAMPMPredicate :: AMPM -> SeriesPredicate
runAMPMPredicate AMPM
ampm = SeriesPredicate
series
  where
  series :: SeriesPredicate
series TimeObject
t TimeContext
_ = ([TimeObject]
past, [TimeObject]
future)
    where
    past :: [TimeObject]
past = [TimeObject] -> [TimeObject]
maybeShrinkFirst ([TimeObject] -> [TimeObject]) -> [TimeObject] -> [TimeObject]
forall a b. (a -> b) -> a -> b
$
      (TimeObject -> TimeObject) -> TimeObject -> [TimeObject]
forall a. (a -> a) -> a -> [a]
iterate (\TimeObject
t -> TimeObject -> Grain -> Integer -> TimeObject
timePlusEnd TimeObject
t Grain
TG.Hour (Integer -> TimeObject) -> (Int -> Integer) -> Int -> TimeObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> TimeObject) -> Int -> TimeObject
forall a b. (a -> b) -> a -> b
$ - Int
step) TimeObject
anchor
    future :: [TimeObject]
future = [TimeObject] -> [TimeObject]
maybeShrinkFirst ([TimeObject] -> [TimeObject]) -> [TimeObject] -> [TimeObject]
forall a b. (a -> b) -> a -> b
$
      (TimeObject -> TimeObject) -> TimeObject -> [TimeObject]
forall a. (a -> a) -> a -> [a]
iterate (\TimeObject
t -> TimeObject -> Grain -> Integer -> TimeObject
timePlusEnd TimeObject
t Grain
TG.Hour (Integer -> TimeObject) -> Integer -> TimeObject
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
step) TimeObject
anchor
    -- to produce time in the future/past we need to adjust
    -- the start/end of the first interval
    maybeShrinkFirst :: [TimeObject] -> [TimeObject]
maybeShrinkFirst (TimeObject
a:[TimeObject]
as) =
      case TimeObject -> TimeObject -> Maybe TimeObject
timeIntersect (TimeObject
t { grain :: Grain
grain = Grain
TG.Day }) TimeObject
a of
        Maybe TimeObject
Nothing -> [TimeObject]
as
        Just TimeObject
ii -> TimeObject
iiTimeObject -> [TimeObject] -> [TimeObject]
forall a. a -> [a] -> [a]
:[TimeObject]
as
    maybeShrinkFirst [TimeObject]
a = [TimeObject]
a
    step :: Int
    step :: Int
step = Int
24
    n :: Integer
n = case AMPM
ampm of
          AMPM
AM -> Integer
0
          AMPM
PM -> Integer
12
    rounded :: TimeObject
rounded = TimeObject -> Grain -> TimeObject
timeRound TimeObject
t Grain
TG.Day
    anchorStart :: TimeObject
anchorStart = TimeObject -> Grain -> Integer -> TimeObject
timePlus TimeObject
rounded Grain
TG.Hour Integer
n
    anchorEnd :: TimeObject
anchorEnd = TimeObject -> Grain -> Integer -> TimeObject
timePlus TimeObject
anchorStart Grain
TG.Hour Integer
12
    -- an interval of length 12h starting either at 12am or 12pm,
    -- the same day as input time
    anchor :: TimeObject
anchor = TimeIntervalType -> TimeObject -> TimeObject -> TimeObject
timeInterval TimeIntervalType
Open TimeObject
anchorStart TimeObject
anchorEnd

runDayOfTheWeekPredicate :: Int -> SeriesPredicate
runDayOfTheWeekPredicate :: Int -> SeriesPredicate
runDayOfTheWeekPredicate Int
n = SeriesPredicate
series
  where
  series :: SeriesPredicate
series TimeObject
t TimeContext
_ = Grain -> Int -> TimeObject -> ([TimeObject], [TimeObject])
timeSequence Grain
TG.Day Int
7 TimeObject
anchor
    where
      Time.UTCTime Day
day DiffTime
_ = TimeObject -> UTCTime
start TimeObject
t
      (Integer
_, Int
_, Int
dayOfWeek) = Day -> (Integer, Int, Int)
Time.toWeekDate Day
day
      daysUntilNextWeek :: Integer
daysUntilNextWeek = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dayOfWeek) Int
7
      anchor :: TimeObject
anchor =
        TimeObject -> Grain -> Integer -> TimeObject
timePlus (TimeObject -> Grain -> TimeObject
timeRound TimeObject
t Grain
TG.Day) Grain
TG.Day Integer
daysUntilNextWeek

runDayOfTheMonthPredicate :: Int -> SeriesPredicate
runDayOfTheMonthPredicate :: Int -> SeriesPredicate
runDayOfTheMonthPredicate Int
n = SeriesPredicate
series
  where
  series :: SeriesPredicate
series TimeObject
t TimeContext
_ =
    ( (TimeObject -> TimeObject) -> [TimeObject] -> [TimeObject]
forall a b. (a -> b) -> [a] -> [b]
map TimeObject -> TimeObject
addDays ([TimeObject] -> [TimeObject])
-> (TimeObject -> [TimeObject]) -> TimeObject -> [TimeObject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TimeObject -> Bool) -> [TimeObject] -> [TimeObject]
forall a. (a -> Bool) -> [a] -> [a]
filter TimeObject -> Bool
enoughDays ([TimeObject] -> [TimeObject])
-> (TimeObject -> [TimeObject]) -> TimeObject -> [TimeObject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TimeObject -> TimeObject) -> TimeObject -> [TimeObject]
forall a. (a -> a) -> a -> [a]
iterate (Int -> TimeObject -> TimeObject
addMonth (Int -> TimeObject -> TimeObject)
-> Int -> TimeObject -> TimeObject
forall a b. (a -> b) -> a -> b
$ - Int
1) (TimeObject -> [TimeObject]) -> TimeObject -> [TimeObject]
forall a b. (a -> b) -> a -> b
$
        Int -> TimeObject -> TimeObject
addMonth (- Int
1) TimeObject
anchor
    , (TimeObject -> TimeObject) -> [TimeObject] -> [TimeObject]
forall a b. (a -> b) -> [a] -> [b]
map TimeObject -> TimeObject
addDays ([TimeObject] -> [TimeObject])
-> ([TimeObject] -> [TimeObject]) -> [TimeObject] -> [TimeObject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TimeObject -> Bool) -> [TimeObject] -> [TimeObject]
forall a. (a -> Bool) -> [a] -> [a]
filter TimeObject -> Bool
enoughDays ([TimeObject] -> [TimeObject]) -> [TimeObject] -> [TimeObject]
forall a b. (a -> b) -> a -> b
$ (TimeObject -> TimeObject) -> TimeObject -> [TimeObject]
forall a. (a -> a) -> a -> [a]
iterate (Int -> TimeObject -> TimeObject
addMonth Int
1) TimeObject
anchor
    )
    where
      enoughDays :: TimeObject -> Bool
      enoughDays :: TimeObject -> Bool
enoughDays TimeObject
t = let Time.UTCTime Day
day DiffTime
_ = TimeObject -> UTCTime
start TimeObject
t
                         (Integer
year, Int
month, Int
_) = Day -> (Integer, Int, Int)
Time.toGregorian Day
day
                     in Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer -> Int -> Int
Time.gregorianMonthLength Integer
year Int
month
      addDays :: TimeObject -> TimeObject
      addDays :: TimeObject -> TimeObject
addDays TimeObject
t = TimeObject -> Grain -> Integer -> TimeObject
timePlus TimeObject
t Grain
TG.Day (Integer -> TimeObject) -> (Int -> Integer) -> Int -> TimeObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> TimeObject) -> Int -> TimeObject
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      addMonth :: Int -> TimeObject -> TimeObject
      addMonth :: Int -> TimeObject -> TimeObject
addMonth Int
i TimeObject
t = TimeObject -> Grain -> Integer -> TimeObject
timePlus TimeObject
t Grain
TG.Month (Integer -> TimeObject) -> Integer -> TimeObject
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
i
      roundMonth :: TimeObject -> TimeObject
      roundMonth :: TimeObject -> TimeObject
roundMonth TimeObject
t = TimeObject -> Grain -> TimeObject
timeRound TimeObject
t Grain
TG.Month
      rounded :: TimeObject
rounded = TimeObject -> TimeObject
roundMonth TimeObject
t
      Time.UTCTime Day
day DiffTime
_ = TimeObject -> UTCTime
start TimeObject
t
      (Integer
_, Int
_, Int
dayOfMonth) = Day -> (Integer, Int, Int)
Time.toGregorian Day
day
      anchor :: TimeObject
anchor = if Int
dayOfMonth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n then TimeObject
rounded else Int -> TimeObject -> TimeObject
addMonth Int
1 TimeObject
rounded

runMonthPredicate :: Int -> SeriesPredicate
runMonthPredicate :: Int -> SeriesPredicate
runMonthPredicate Int
n = SeriesPredicate
series
  where
  series :: SeriesPredicate
series TimeObject
t TimeContext
_ = Grain -> Int -> TimeObject -> ([TimeObject], [TimeObject])
timeSequence Grain
TG.Year Int
1 TimeObject
anchor
    where
      rounded :: TimeObject
rounded =
        TimeObject -> Grain -> Integer -> TimeObject
timePlus (TimeObject -> Grain -> TimeObject
timeRound TimeObject
t Grain
TG.Year) Grain
TG.Month (Integer -> TimeObject) -> (Int -> Integer) -> Int -> TimeObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> TimeObject) -> Int -> TimeObject
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      anchor :: TimeObject
anchor = if TimeObject -> TimeObject -> Bool
timeStartsBeforeTheEndOf TimeObject
t TimeObject
rounded
        then TimeObject
rounded
        else TimeObject -> Grain -> Integer -> TimeObject
timePlus TimeObject
rounded Grain
TG.Year Integer
1

runYearPredicate :: Int -> SeriesPredicate
runYearPredicate :: Int -> SeriesPredicate
runYearPredicate Int
n = SeriesPredicate
series
  where
  series :: SeriesPredicate
series TimeObject
t TimeContext
_ =
    if Integer
tyear Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
year
      then ([], [TimeObject
y])
      else ([TimeObject
y], [])
    where
      Time.UTCTime Day
day DiffTime
_ = TimeObject -> UTCTime
start TimeObject
t
      (Integer
tyear, Int
_, Int
_) = Day -> (Integer, Int, Int)
Time.toGregorian Day
day
      year :: Integer
year = Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n
      y :: TimeObject
y = TimeObject -> Grain -> Integer -> TimeObject
timePlus (TimeObject -> Grain -> TimeObject
timeRound TimeObject
t Grain
TG.Year) Grain
TG.Year (Integer -> TimeObject) -> Integer -> TimeObject
forall a b. (a -> b) -> a -> b
$ Integer
year Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
tyear

-- Limits how deep into lists of segments to look
safeMax :: Int
safeMax :: Int
safeMax = Int
10

runReplaceIntersectPredicate
  :: Predicate -> Predicate -> Predicate -> SeriesPredicate
runReplaceIntersectPredicate :: Predicate -> Predicate -> Predicate -> SeriesPredicate
runReplaceIntersectPredicate Predicate
pred1 Predicate
pred2 Predicate
pred3 = SeriesPredicate
-> SeriesPredicate -> SeriesPredicate -> SeriesPredicate
runComposeWithReplacement
  (Predicate -> SeriesPredicate
runPredicate Predicate
pred1) (Predicate -> SeriesPredicate
runPredicate Predicate
pred2) (Predicate -> SeriesPredicate
runPredicate Predicate
pred3)

-- If pred1 intersects with pred2, returns pred3 otherwise pred2
-- Caveat: only works if all predicates are aligned (e.g. once a year)
runComposeWithReplacement
  :: SeriesPredicate -> SeriesPredicate -> SeriesPredicate -> SeriesPredicate
runComposeWithReplacement :: SeriesPredicate
-> SeriesPredicate -> SeriesPredicate -> SeriesPredicate
runComposeWithReplacement SeriesPredicate
pred1 SeriesPredicate
pred2 SeriesPredicate
pred3 = SeriesPredicate
series
  where
  series :: SeriesPredicate
series TimeObject
nowTime TimeContext
context = ([TimeObject]
backward, [TimeObject]
forward)
    where
    ([TimeObject]
past1, [TimeObject]
future1) = SeriesPredicate
pred1 TimeObject
nowTime TimeContext
context
    ([TimeObject]
past2, [TimeObject]
future2) = SeriesPredicate
pred2 TimeObject
nowTime TimeContext
context
    ([TimeObject]
past3, [TimeObject]
future3) = SeriesPredicate
pred3 TimeObject
nowTime TimeContext
context

    computeSerie :: [[TimeObject]] -> [TimeObject]
    computeSerie :: [[TimeObject]] -> [TimeObject]
computeSerie [[TimeObject]
tokens1,[TimeObject]
tokens2,[TimeObject]
tokens3] =
      (TimeObject -> TimeObject -> TimeObject -> TimeObject)
-> [TimeObject] -> [TimeObject] -> [TimeObject] -> [TimeObject]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (\TimeObject
token1 TimeObject
token2 TimeObject
token3 -> case TimeObject -> TimeObject -> Maybe TimeObject
timeIntersect TimeObject
token1 TimeObject
token2 of
        Just TimeObject
_ -> TimeObject
token3
        Maybe TimeObject
Nothing -> TimeObject
token2
      ) [TimeObject]
tokens1 [TimeObject]
tokens2 [TimeObject]
tokens3
    computeSerie [[TimeObject]]
_ = []

    backwardBounded :: [TimeObject] -> [TimeObject]
backwardBounded =
      (TimeObject -> Bool) -> [TimeObject] -> [TimeObject]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\TimeObject
t -> TimeObject -> TimeObject -> Bool
timeStartsBeforeTheEndOf (TimeContext -> TimeObject
minTime TimeContext
context) TimeObject
t)
      ([TimeObject] -> [TimeObject])
-> ([TimeObject] -> [TimeObject]) -> [TimeObject] -> [TimeObject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [TimeObject] -> [TimeObject]
forall a. Int -> [a] -> [a]
take Int
safeMax
    forwardBounded :: [TimeObject] -> [TimeObject]
forwardBounded =
      (TimeObject -> Bool) -> [TimeObject] -> [TimeObject]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\TimeObject
t -> TimeObject -> TimeObject -> Bool
timeStartsBeforeTheEndOf TimeObject
t (TimeContext -> TimeObject
maxTime TimeContext
context))
      ([TimeObject] -> [TimeObject])
-> ([TimeObject] -> [TimeObject]) -> [TimeObject] -> [TimeObject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [TimeObject] -> [TimeObject]
forall a. Int -> [a] -> [a]
take Int
safeMax

    backward :: [TimeObject]
backward = [[TimeObject]] -> [TimeObject]
computeSerie ([[TimeObject]] -> [TimeObject]) -> [[TimeObject]] -> [TimeObject]
forall a b. (a -> b) -> a -> b
$ ([TimeObject] -> [TimeObject]) -> [[TimeObject]] -> [[TimeObject]]
forall a b. (a -> b) -> [a] -> [b]
map [TimeObject] -> [TimeObject]
backwardBounded [[TimeObject]
past1, [TimeObject]
past2, [TimeObject]
past3]
    forward :: [TimeObject]
forward = [[TimeObject]] -> [TimeObject]
computeSerie ([[TimeObject]] -> [TimeObject]) -> [[TimeObject]] -> [TimeObject]
forall a b. (a -> b) -> a -> b
$ ([TimeObject] -> [TimeObject]) -> [[TimeObject]] -> [[TimeObject]]
forall a b. (a -> b) -> [a] -> [b]
map [TimeObject] -> [TimeObject]
forwardBounded [[TimeObject]
future1, [TimeObject]
future2, [TimeObject]
future3]

runIntersectPredicate :: Predicate -> Predicate -> SeriesPredicate
runIntersectPredicate :: Predicate -> Predicate -> SeriesPredicate
runIntersectPredicate Predicate
pred1 Predicate
pred2 =
  SeriesPredicate -> SeriesPredicate -> SeriesPredicate
runCompose (Predicate -> SeriesPredicate
runPredicate Predicate
pred1) (Predicate -> SeriesPredicate
runPredicate Predicate
pred2)

-- Performs best when pred1 is smaller grain than pred2
runCompose :: SeriesPredicate -> SeriesPredicate -> SeriesPredicate
runCompose :: SeriesPredicate -> SeriesPredicate -> SeriesPredicate
runCompose SeriesPredicate
pred1 SeriesPredicate
pred2 = SeriesPredicate
series
  where
  series :: SeriesPredicate
series TimeObject
nowTime TimeContext
context = ([TimeObject]
backward, [TimeObject]
forward)
    where
    ([TimeObject]
past, [TimeObject]
future) = SeriesPredicate
pred2 TimeObject
nowTime TimeContext
context
    computeSerie :: [TimeObject] -> [TimeObject]
computeSerie [TimeObject]
tokens =
      [TimeObject
t | TimeObject
time1 <- Int -> [TimeObject] -> [TimeObject]
forall a. Int -> [a] -> [a]
take Int
safeMax [TimeObject]
tokens
         , TimeObject
t <- (TimeObject -> Maybe TimeObject) -> [TimeObject] -> [TimeObject]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TimeObject -> TimeObject -> Maybe TimeObject
timeIntersect TimeObject
time1) ([TimeObject] -> [TimeObject])
-> (TimeContext -> [TimeObject]) -> TimeContext -> [TimeObject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                (TimeObject -> Bool) -> [TimeObject] -> [TimeObject]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (TimeObject -> TimeObject -> Bool
startsBefore TimeObject
time1) ([TimeObject] -> [TimeObject])
-> (TimeContext -> [TimeObject]) -> TimeContext -> [TimeObject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                ([TimeObject], [TimeObject]) -> [TimeObject]
forall a b. (a, b) -> b
snd (([TimeObject], [TimeObject]) -> [TimeObject])
-> (TimeContext -> ([TimeObject], [TimeObject]))
-> TimeContext
-> [TimeObject]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SeriesPredicate
pred1 TimeObject
time1 (TimeContext -> [TimeObject]) -> TimeContext -> [TimeObject]
forall a b. (a -> b) -> a -> b
$ TimeObject -> TimeContext
fixedRange TimeObject
time1
      ]

    startsBefore :: TimeObject -> TimeObject -> Bool
startsBefore TimeObject
t1 TimeObject
this = TimeObject -> TimeObject -> Bool
timeStartsBeforeTheEndOf TimeObject
this TimeObject
t1
    fixedRange :: TimeObject -> TimeContext
fixedRange TimeObject
t1 = TimeContext
context {minTime :: TimeObject
minTime = TimeObject
t1, maxTime :: TimeObject
maxTime = TimeObject
t1}

    backward :: [TimeObject]
backward = [TimeObject] -> [TimeObject]
computeSerie ([TimeObject] -> [TimeObject]) -> [TimeObject] -> [TimeObject]
forall a b. (a -> b) -> a -> b
$ (TimeObject -> Bool) -> [TimeObject] -> [TimeObject]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\TimeObject
t ->
      TimeObject -> TimeObject -> Bool
timeStartsBeforeTheEndOf (TimeContext -> TimeObject
minTime TimeContext
context) TimeObject
t) [TimeObject]
past
    forward :: [TimeObject]
forward = [TimeObject] -> [TimeObject]
computeSerie ([TimeObject] -> [TimeObject]) -> [TimeObject] -> [TimeObject]
forall a b. (a -> b) -> a -> b
$ (TimeObject -> Bool) -> [TimeObject] -> [TimeObject]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\TimeObject
t ->
      TimeObject -> TimeObject -> Bool
timeStartsBeforeTheEndOf TimeObject
t (TimeContext -> TimeObject
maxTime TimeContext
context)) [TimeObject]
future

runTimeIntervalsPredicate
  :: TimeIntervalType -> Predicate
  -> Predicate -> SeriesPredicate
runTimeIntervalsPredicate :: TimeIntervalType -> Predicate -> Predicate -> SeriesPredicate
runTimeIntervalsPredicate TimeIntervalType
intervalType Predicate
pred1 Predicate
pred2 = Bool
-> (TimeObject -> TimeContext -> Maybe TimeObject)
-> Predicate
-> SeriesPredicate
timeSeqMap Bool
True TimeObject -> TimeContext -> Maybe TimeObject
f Predicate
pred1
  where
    -- Pick the first interval *after* the given time segment
    f :: TimeObject -> TimeContext -> Maybe TimeObject
f TimeObject
thisSegment TimeContext
ctx = case Predicate -> SeriesPredicate
runPredicate Predicate
pred2 TimeObject
thisSegment TimeContext
ctx of
      ([TimeObject]
_, TimeObject
firstFuture:[TimeObject]
_) -> TimeObject -> Maybe TimeObject
forall a. a -> Maybe a
Just (TimeObject -> Maybe TimeObject) -> TimeObject -> Maybe TimeObject
forall a b. (a -> b) -> a -> b
$
        TimeIntervalType -> TimeObject -> TimeObject -> TimeObject
timeInterval TimeIntervalType
intervalType TimeObject
thisSegment TimeObject
firstFuture
      ([TimeObject], [TimeObject])
_ -> Maybe TimeObject
forall a. Maybe a
Nothing

-- Limits how deep into lists of segments to look
safeMaxInterval :: Int
safeMaxInterval :: Int
safeMaxInterval = Int
12

-- | Applies `f` to each interval yielded by `g`.
-- | Intervals including "now" are in the future.
timeSeqMap
  :: Bool
     -- Given an interval and range, compute a single new interval
  -> (TimeObject -> TimeContext -> Maybe TimeObject)
     -- First-layer series generator
  -> Predicate
     -- Series generator for values that come from `f`
  -> SeriesPredicate
timeSeqMap :: Bool
-> (TimeObject -> TimeContext -> Maybe TimeObject)
-> Predicate
-> SeriesPredicate
timeSeqMap Bool
dontReverse TimeObject -> TimeContext -> Maybe TimeObject
f Predicate
g = SeriesPredicate
series
  where
  series :: SeriesPredicate
series TimeObject
nowTime TimeContext
context = ([TimeObject]
past, [TimeObject]
future)
    where
    -- computes a single interval from `f` based on each interval in the series
    applyF :: [TimeObject] -> [TimeObject]
applyF [TimeObject]
series = (TimeObject -> Maybe TimeObject) -> [TimeObject] -> [TimeObject]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\TimeObject
x -> TimeObject -> TimeContext -> Maybe TimeObject
f TimeObject
x TimeContext
context) ([TimeObject] -> [TimeObject]) -> [TimeObject] -> [TimeObject]
forall a b. (a -> b) -> a -> b
$ Int -> [TimeObject] -> [TimeObject]
forall a. Int -> [a] -> [a]
take Int
safeMaxInterval [TimeObject]
series

    ([TimeObject]
firstPast, [TimeObject]
firstFuture) = Predicate -> SeriesPredicate
runPredicate Predicate
g TimeObject
nowTime TimeContext
context
    ([TimeObject]
past1, [TimeObject]
future1) = ([TimeObject] -> [TimeObject]
applyF [TimeObject]
firstPast, [TimeObject] -> [TimeObject]
applyF [TimeObject]
firstFuture)

    -- Separate what's before and after now from the past's series
    ([TimeObject]
newFuture, [TimeObject]
stillPast) =
      (TimeObject -> Bool)
-> [TimeObject] -> ([TimeObject], [TimeObject])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (TimeObject -> TimeObject -> Bool
timeStartsBeforeTheEndOf TimeObject
nowTime) [TimeObject]
past1
    -- A series that ends at the earliest time
    oldPast :: [TimeObject]
oldPast = (TimeObject -> Bool) -> [TimeObject] -> [TimeObject]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile
      (TimeObject -> TimeObject -> Bool
timeStartsBeforeTheEndOf (TimeObject -> TimeObject -> Bool)
-> TimeObject -> TimeObject -> Bool
forall a b. (a -> b) -> a -> b
$ TimeContext -> TimeObject
minTime TimeContext
context)
      [TimeObject]
stillPast

    -- Separate what's before and after now from the future's series
    ([TimeObject]
newPast, [TimeObject]
stillFuture) =
      (TimeObject -> Bool)
-> [TimeObject] -> ([TimeObject], [TimeObject])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (TimeObject -> TimeObject -> Bool
timeStartsBeforeTheEndOf TimeObject
nowTime) [TimeObject]
future1
    -- A series that ends at the furthest future time
    oldFuture :: [TimeObject]
oldFuture = (TimeObject -> Bool) -> [TimeObject] -> [TimeObject]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile
      (\TimeObject
x -> TimeObject -> TimeObject -> Bool
timeStartsBeforeTheEndOf TimeObject
x (TimeObject -> Bool) -> TimeObject -> Bool
forall a b. (a -> b) -> a -> b
$ TimeContext -> TimeObject
maxTime TimeContext
context)
      [TimeObject]
stillFuture

    -- Reverse the list if needed?
    applyRev :: [TimeObject] -> [TimeObject]
applyRev [TimeObject]
series = if Bool
dontReverse then [TimeObject]
series else [TimeObject] -> [TimeObject]
forall a. [a] -> [a]
reverse [TimeObject]
series
    ([TimeObject]
sortedPast, [TimeObject]
sortedFuture) = ([TimeObject] -> [TimeObject]
applyRev [TimeObject]
newPast, [TimeObject] -> [TimeObject]
applyRev [TimeObject]
newFuture)

    -- Past is the past from the future's series with the
    -- past from the past's series tacked on
    past :: [TimeObject]
past = [TimeObject]
sortedPast [TimeObject] -> [TimeObject] -> [TimeObject]
forall a. [a] -> [a] -> [a]
++ [TimeObject]
oldPast

    -- Future is the future from the past's series with the
    -- future from the future's series tacked on
    future :: [TimeObject]
future = [TimeObject]
sortedFuture [TimeObject] -> [TimeObject] -> [TimeObject]
forall a. [a] -> [a] -> [a]
++ [TimeObject]
oldFuture


timeSequence
  :: TG.Grain
  -> Int
  -> TimeObject
  -> ([TimeObject], [TimeObject])
timeSequence :: Grain -> Int -> TimeObject -> ([TimeObject], [TimeObject])
timeSequence Grain
grain Int
step TimeObject
anchor =
  ( Int -> [TimeObject] -> [TimeObject]
forall a. Int -> [a] -> [a]
drop Int
1 ([TimeObject] -> [TimeObject]) -> [TimeObject] -> [TimeObject]
forall a b. (a -> b) -> a -> b
$ (TimeObject -> TimeObject) -> TimeObject -> [TimeObject]
forall a. (a -> a) -> a -> [a]
iterate (Int -> TimeObject -> TimeObject
f (Int -> TimeObject -> TimeObject)
-> Int -> TimeObject -> TimeObject
forall a b. (a -> b) -> a -> b
$ - Int
step) TimeObject
anchor
  , (TimeObject -> TimeObject) -> TimeObject -> [TimeObject]
forall a. (a -> a) -> a -> [a]
iterate (Int -> TimeObject -> TimeObject
f Int
step) TimeObject
anchor
  )
  where
    f :: Int -> TimeObject -> TimeObject
    f :: Int -> TimeObject -> TimeObject
f Int
n TimeObject
t = TimeObject -> Grain -> Integer -> TimeObject
timePlus TimeObject
t Grain
grain (Integer -> TimeObject) -> Integer -> TimeObject
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n

-- | Zero-pad `x` to reach length `n`.
pad :: Int -> Int -> Text
pad :: Int -> Int -> Text
pad Int
n Int
x
  | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
magnitude = Int -> Text -> Text
Text.replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
s) Text
"0" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
  | Bool
otherwise      = Text
s
  where
    magnitude :: Int
magnitude = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round ((Float
10 :: Float) Float -> Float -> Float
forall a. Floating a => a -> a -> a
** Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) :: Float)
    s :: Text
s = Int -> Text
forall a. TextShow a => a -> Text
showt Int
x

-- | Return the timezone offset portion of the RFC3339 format, e.g. "-02:00".
timezoneOffset :: Time.TimeZone -> Text
timezoneOffset :: TimeZone -> Text
timezoneOffset (Time.TimeZone Int
t Bool
_ String
_) = [Text] -> Text
Text.concat [Text
sign, Text
hh, Text
":", Text
mm]
  where
    (Text
sign, Int
t') = if Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then (Text
"-", Int -> Int
forall a. Num a => a -> a
negate Int
t) else (Text
"+", Int
t)
    (Text
hh, Text
mm) = (Int -> Text) -> (Int, Int) -> (Text, Text)
forall a b. (a -> b) -> (a, a) -> (b, b)
both (Int -> Int -> Text
pad Int
2) ((Int, Int) -> (Text, Text)) -> (Int, Int) -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod Int
t' Int
60

-- | Return a RFC3339 formatted time, e.g. "2013-02-12T04:30:00.000-02:00".
-- | Backward-compatible with Duckling: fraction of second is milli and padded.
toRFC3339 :: Time.ZonedTime -> Text
toRFC3339 :: ZonedTime -> Text
toRFC3339 (Time.ZonedTime (Time.LocalTime Day
day (Time.TimeOfDay Int
h Int
m Pico
s)) TimeZone
tz) =
  [Text] -> Text
Text.concat
    [ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Day -> String
Time.showGregorian Day
day
    , Text
"T"
    , Int -> Int -> Text
pad Int
2 Int
h
    , Text
":"
    , Int -> Int -> Text
pad Int
2 Int
m
    , Text
":"
    , Int -> Int -> Text
pad Int
2 (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Pico -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Pico
s
    , Text
"."
    , Int -> Int -> Text
pad Int
3 (Int -> Text) -> (Pico -> Int) -> Pico -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pico -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Pico -> Text) -> Pico -> Text
forall a b. (a -> b) -> a -> b
$ (Pico
s Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
- Integer -> Pico
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Pico -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor Pico
s :: Integer)) Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
* Pico
1000
    , TimeZone -> Text
timezoneOffset TimeZone
tz
    ]

instantValue :: Series.TimeZoneSeries -> Time.UTCTime -> Grain -> InstantValue
instantValue :: TimeZoneSeries -> UTCTime -> Grain -> InstantValue
instantValue TimeZoneSeries
tzSeries UTCTime
t Grain
g = InstantValue :: ZonedTime -> Grain -> InstantValue
InstantValue
  { vValue :: ZonedTime
vValue = UTCTime -> TimeZone -> ZonedTime
fromUTC UTCTime
t (TimeZone -> ZonedTime) -> TimeZone -> ZonedTime
forall a b. (a -> b) -> a -> b
$ TimeZoneSeries -> UTCTime -> TimeZone
Series.timeZoneFromSeries TimeZoneSeries
tzSeries UTCTime
t
  , vGrain :: Grain
vGrain = Grain
g
  }

timeValue :: Series.TimeZoneSeries -> TimeObject -> SingleTimeValue
timeValue :: TimeZoneSeries -> TimeObject -> SingleTimeValue
timeValue TimeZoneSeries
tzSeries (TimeObject UTCTime
s Grain
g Maybe UTCTime
Nothing) =
  InstantValue -> SingleTimeValue
SimpleValue (InstantValue -> SingleTimeValue)
-> InstantValue -> SingleTimeValue
forall a b. (a -> b) -> a -> b
$ TimeZoneSeries -> UTCTime -> Grain -> InstantValue
instantValue TimeZoneSeries
tzSeries UTCTime
s Grain
g
timeValue TimeZoneSeries
tzSeries (TimeObject UTCTime
s Grain
g (Just UTCTime
e)) = (InstantValue, InstantValue) -> SingleTimeValue
IntervalValue
  ( TimeZoneSeries -> UTCTime -> Grain -> InstantValue
instantValue TimeZoneSeries
tzSeries UTCTime
s Grain
g
  , TimeZoneSeries -> UTCTime -> Grain -> InstantValue
instantValue TimeZoneSeries
tzSeries UTCTime
e Grain
g
  )

openInterval
  :: Series.TimeZoneSeries -> IntervalDirection -> TimeObject -> SingleTimeValue
openInterval :: TimeZoneSeries
-> IntervalDirection -> TimeObject -> SingleTimeValue
openInterval TimeZoneSeries
tzSeries IntervalDirection
direction (TimeObject UTCTime
s Grain
g Maybe UTCTime
_) = (InstantValue, IntervalDirection) -> SingleTimeValue
OpenIntervalValue
  ( TimeZoneSeries -> UTCTime -> Grain -> InstantValue
instantValue TimeZoneSeries
tzSeries UTCTime
s Grain
g
  , IntervalDirection
direction
  )

-- -----------------------------------------------------------------
-- Time object helpers

timeRound :: TimeObject -> TG.Grain -> TimeObject
timeRound :: TimeObject -> Grain -> TimeObject
timeRound TimeObject
t Grain
TG.Week = TimeObject :: UTCTime -> Grain -> Maybe UTCTime -> TimeObject
TimeObject {start :: UTCTime
start = UTCTime
s, grain :: Grain
grain = Grain
TG.Week, end :: Maybe UTCTime
end = Maybe UTCTime
forall a. Maybe a
Nothing}
  where
    Time.UTCTime Day
day DiffTime
diffTime = TimeObject -> UTCTime
start (TimeObject -> UTCTime) -> TimeObject -> UTCTime
forall a b. (a -> b) -> a -> b
$ TimeObject -> Grain -> TimeObject
timeRound TimeObject
t Grain
TG.Day
    (Integer
year, Int
week, Int
_) = Day -> (Integer, Int, Int)
Time.toWeekDate Day
day
    newDay :: Day
newDay = Integer -> Int -> Int -> Day
Time.fromWeekDate Integer
year Int
week Int
1
    s :: UTCTime
s = Day -> DiffTime -> UTCTime
Time.UTCTime Day
newDay DiffTime
diffTime
timeRound TimeObject
t Grain
TG.Quarter = TimeObject
newTime {grain :: Grain
grain = Grain
TG.Quarter}
  where
    monthTime :: TimeObject
monthTime = TimeObject -> Grain -> TimeObject
timeRound TimeObject
t Grain
TG.Month
    Time.UTCTime Day
day DiffTime
_ = TimeObject -> UTCTime
start TimeObject
monthTime
    (Integer
_, Int
month, Int
_) = Day -> (Integer, Int, Int)
Time.toGregorian Day
day
    newTime :: TimeObject
newTime = TimeObject -> Grain -> Integer -> TimeObject
timePlus TimeObject
monthTime Grain
TG.Month (Integer -> TimeObject) -> (Int -> Integer) -> Int -> TimeObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> TimeObject) -> Int -> TimeObject
forall a b. (a -> b) -> a -> b
$ - (Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod (Int
month Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
3)
timeRound TimeObject
t Grain
grain = TimeObject :: UTCTime -> Grain -> Maybe UTCTime -> TimeObject
TimeObject {start :: UTCTime
start = UTCTime
s, grain :: Grain
grain = Grain
grain, end :: Maybe UTCTime
end = Maybe UTCTime
forall a. Maybe a
Nothing}
  where
    Time.UTCTime Day
day DiffTime
diffTime = TimeObject -> UTCTime
start TimeObject
t
    timeOfDay :: TimeOfDay
timeOfDay = DiffTime -> TimeOfDay
Time.timeToTimeOfDay DiffTime
diffTime
    (Integer
year, Int
month, Int
dayOfMonth) = Day -> (Integer, Int, Int)
Time.toGregorian Day
day
    Time.TimeOfDay Int
hours Int
mins Pico
secs = TimeOfDay
timeOfDay
    newMonth :: Int
newMonth = if Grain
grain Grain -> Grain -> Bool
forall a. Ord a => a -> a -> Bool
> Grain
TG.Month then Int
1 else Int
month
    newDayOfMonth :: Int
newDayOfMonth = if Grain
grain Grain -> Grain -> Bool
forall a. Ord a => a -> a -> Bool
> Grain
TG.Day then Int
1 else Int
dayOfMonth
    newDay :: Day
newDay = Integer -> Int -> Int -> Day
Time.fromGregorian Integer
year Int
newMonth Int
newDayOfMonth
    newHours :: Int
newHours = if Grain
grain Grain -> Grain -> Bool
forall a. Ord a => a -> a -> Bool
> Grain
TG.Hour then Int
0 else Int
hours
    newMins :: Int
newMins = if Grain
grain Grain -> Grain -> Bool
forall a. Ord a => a -> a -> Bool
> Grain
TG.Minute then Int
0 else Int
mins
    newSecs :: Pico
newSecs = if Grain
grain Grain -> Grain -> Bool
forall a. Ord a => a -> a -> Bool
> Grain
TG.Second then Pico
0 else Pico
secs
    newDiffTime :: DiffTime
newDiffTime = TimeOfDay -> DiffTime
Time.timeOfDayToTime (TimeOfDay -> DiffTime) -> TimeOfDay -> DiffTime
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Pico -> TimeOfDay
Time.TimeOfDay Int
newHours Int
newMins Pico
newSecs
    s :: UTCTime
s = Day -> DiffTime -> UTCTime
Time.UTCTime Day
newDay DiffTime
newDiffTime

timePlus :: TimeObject -> TG.Grain -> Integer -> TimeObject
timePlus :: TimeObject -> Grain -> Integer -> TimeObject
timePlus (TimeObject UTCTime
start Grain
grain Maybe UTCTime
_) Grain
theGrain Integer
n = TimeObject :: UTCTime -> Grain -> Maybe UTCTime -> TimeObject
TimeObject
  { start :: UTCTime
start = UTCTime -> Grain -> Integer -> UTCTime
TG.add UTCTime
start Grain
theGrain Integer
n
  , grain :: Grain
grain = Grain -> Grain -> Grain
forall a. Ord a => a -> a -> a
min Grain
grain Grain
theGrain
  , end :: Maybe UTCTime
end = Maybe UTCTime
forall a. Maybe a
Nothing
  }

-- | Shifts the whole interval by n units of theGrain
-- Returned interval has the same length as the input one
timePlusEnd :: TimeObject -> TG.Grain -> Integer -> TimeObject
timePlusEnd :: TimeObject -> Grain -> Integer -> TimeObject
timePlusEnd (TimeObject UTCTime
start Grain
grain Maybe UTCTime
end) Grain
theGrain Integer
n = TimeObject :: UTCTime -> Grain -> Maybe UTCTime -> TimeObject
TimeObject
  { start :: UTCTime
start = UTCTime -> Grain -> Integer -> UTCTime
TG.add UTCTime
start Grain
theGrain Integer
n
  , grain :: Grain
grain = Grain -> Grain -> Grain
forall a. Ord a => a -> a -> a
min Grain
grain Grain
theGrain
  , end :: Maybe UTCTime
end = UTCTime -> Grain -> Integer -> UTCTime
TG.add (UTCTime -> Grain -> Integer -> UTCTime)
-> Maybe UTCTime -> Maybe (Grain -> Integer -> UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
end Maybe (Grain -> Integer -> UTCTime)
-> Maybe Grain -> Maybe (Integer -> UTCTime)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Grain -> Maybe Grain
forall (m :: * -> *) a. Monad m => a -> m a
return Grain
theGrain Maybe (Integer -> UTCTime) -> Maybe Integer -> Maybe UTCTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Integer -> Maybe Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
n
  }

timeEnd :: TimeObject -> Time.UTCTime
timeEnd :: TimeObject -> UTCTime
timeEnd (TimeObject UTCTime
start Grain
grain Maybe UTCTime
end) = UTCTime -> Maybe UTCTime -> UTCTime
forall a. a -> Maybe a -> a
fromMaybe (UTCTime -> Grain -> Integer -> UTCTime
TG.add UTCTime
start Grain
grain Integer
1) Maybe UTCTime
end

timeStartingAtTheEndOf :: TimeObject -> TimeObject
timeStartingAtTheEndOf :: TimeObject -> TimeObject
timeStartingAtTheEndOf TimeObject
t = TimeObject :: UTCTime -> Grain -> Maybe UTCTime -> TimeObject
TimeObject
  {start :: UTCTime
start = TimeObject -> UTCTime
timeEnd TimeObject
t, end :: Maybe UTCTime
end = Maybe UTCTime
forall a. Maybe a
Nothing, grain :: Grain
grain = TimeObject -> Grain
grain TimeObject
t}

-- | Closed if the interval between A and B should include B
-- Open if the interval should end right before B
data TimeIntervalType = Open | Closed
  deriving (TimeIntervalType -> TimeIntervalType -> Bool
(TimeIntervalType -> TimeIntervalType -> Bool)
-> (TimeIntervalType -> TimeIntervalType -> Bool)
-> Eq TimeIntervalType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeIntervalType -> TimeIntervalType -> Bool
$c/= :: TimeIntervalType -> TimeIntervalType -> Bool
== :: TimeIntervalType -> TimeIntervalType -> Bool
$c== :: TimeIntervalType -> TimeIntervalType -> Bool
Eq, Int -> TimeIntervalType -> ShowS
[TimeIntervalType] -> ShowS
TimeIntervalType -> String
(Int -> TimeIntervalType -> ShowS)
-> (TimeIntervalType -> String)
-> ([TimeIntervalType] -> ShowS)
-> Show TimeIntervalType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeIntervalType] -> ShowS
$cshowList :: [TimeIntervalType] -> ShowS
show :: TimeIntervalType -> String
$cshow :: TimeIntervalType -> String
showsPrec :: Int -> TimeIntervalType -> ShowS
$cshowsPrec :: Int -> TimeIntervalType -> ShowS
Show)

timeInterval :: TimeIntervalType -> TimeObject -> TimeObject -> TimeObject
timeInterval :: TimeIntervalType -> TimeObject -> TimeObject -> TimeObject
timeInterval
  TimeIntervalType
intervalType
  TimeObject{start :: TimeObject -> UTCTime
start = UTCTime
s1, grain :: TimeObject -> Grain
grain = Grain
g1}
  TimeObject{start :: TimeObject -> UTCTime
start = UTCTime
s2, end :: TimeObject -> Maybe UTCTime
end = Maybe UTCTime
e2, grain :: TimeObject -> Grain
grain = Grain
g2} = TimeObject :: UTCTime -> Grain -> Maybe UTCTime -> TimeObject
TimeObject
  { start :: UTCTime
start = UTCTime
s1
  , grain :: Grain
grain = Grain
g'
  , end :: Maybe UTCTime
end = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ case TimeIntervalType
intervalType of
      TimeIntervalType
Open -> UTCTime
s2
      TimeIntervalType
Closed -> UTCTime -> Maybe UTCTime -> UTCTime
forall a. a -> Maybe a -> a
fromMaybe (UTCTime -> Grain -> Integer -> UTCTime
TG.add UTCTime
s2 Grain
g2' Integer
1) Maybe UTCTime
e2
  }
  where
    g' :: Grain
g' = Grain -> Grain -> Grain
forall a. Ord a => a -> a -> a
min Grain
g1 Grain
g2
    g2' :: Grain
g2'
      | Grain
g1 Grain -> Grain -> Bool
forall a. Ord a => a -> a -> Bool
< Grain
TG.Day Bool -> Bool -> Bool
&& Grain
g2 Grain -> Grain -> Bool
forall a. Ord a => a -> a -> Bool
< Grain
TG.Day = Grain
g'
      | Bool
otherwise = Grain
g2

timeStartsBeforeTheEndOf :: TimeObject -> TimeObject -> Bool
timeStartsBeforeTheEndOf :: TimeObject -> TimeObject -> Bool
timeStartsBeforeTheEndOf TimeObject
t1 TimeObject
t2 = TimeObject -> UTCTime
start TimeObject
t1 UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< TimeObject -> UTCTime
timeEnd TimeObject
t2

timeBefore :: TimeObject -> TimeObject -> Bool
timeBefore :: TimeObject -> TimeObject -> Bool
timeBefore TimeObject
t1 TimeObject
t2 = TimeObject -> UTCTime
start TimeObject
t1 UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< TimeObject -> UTCTime
start TimeObject
t2

-- | Intersection between two `TimeObject`.
-- The resulting grain and end fields are the smallest.
-- Prefers intervals when the range is equal.
timeIntersect :: TimeObject -> TimeObject -> Maybe TimeObject
timeIntersect :: TimeObject -> TimeObject -> Maybe TimeObject
timeIntersect TimeObject
t1 TimeObject
t2
  | UTCTime
s1 UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
s2 = TimeObject -> TimeObject -> Maybe TimeObject
timeIntersect TimeObject
t2 TimeObject
t1
  | UTCTime
e1 UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
s2 = Maybe TimeObject
forall a. Maybe a
Nothing
  | UTCTime
e1 UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
e2 Bool -> Bool -> Bool
|| UTCTime
s1 UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
s2 Bool -> Bool -> Bool
&& UTCTime
e1 UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
e2 Bool -> Bool -> Bool
&& Maybe UTCTime -> Bool
forall a. Maybe a -> Bool
isJust Maybe UTCTime
end1 = TimeObject -> Maybe TimeObject
forall a. a -> Maybe a
Just TimeObject :: UTCTime -> Grain -> Maybe UTCTime -> TimeObject
TimeObject
    {start :: UTCTime
start = UTCTime
s2, end :: Maybe UTCTime
end = Maybe UTCTime
end1, grain :: Grain
grain = Grain
g'}
  | Bool
otherwise = TimeObject -> Maybe TimeObject
forall a. a -> Maybe a
Just TimeObject
t2 {grain :: Grain
grain = Grain
g'}
  where
    TimeObject UTCTime
s1 Grain
g1 Maybe UTCTime
end1 = TimeObject
t1
    TimeObject UTCTime
s2 Grain
g2 Maybe UTCTime
_    = TimeObject
t2
    e1 :: UTCTime
e1 = TimeObject -> UTCTime
timeEnd TimeObject
t1
    e2 :: UTCTime
e2 = TimeObject -> UTCTime
timeEnd TimeObject
t2
    g' :: Grain
g' = Grain -> Grain -> Grain
forall a. Ord a => a -> a -> a
min Grain
g1 Grain
g2