packages feed

polysemy-time (empty) → 0.1.0.0

raw patch · 17 files changed

+1270/−0 lines, 17 filesdep +aesondep +basedep +composition

Dependencies added: aeson, base, composition, containers, data-default, either, hedgehog, polysemy, polysemy-plugin, polysemy-test, polysemy-time, relude, string-interpolate, tasty, tasty-hedgehog, template-haskell, text, time, torsor

Files

+ LICENSE view
@@ -0,0 +1,34 @@+Copyright (c) 2020 Torsten Schmits++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the+following conditions are met:++  1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following+  disclaimer.+  2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following+  disclaimer in the documentation and/or other materials provided with the distribution.++Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those+receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except+for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired+or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by:++  (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of+  contributors, in source or binary form) alone; or+  (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such+  copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to+  be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution.++Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this+license, whether expressly, by implication, estoppel or otherwise.++DISCLAIMER++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ changelog.md view
@@ -0,0 +1,2 @@+# 0.1.0.0+* initial release
+ lib/Polysemy/Time.hs view
@@ -0,0 +1,79 @@+{-|+This package provides a Polysemy effect for interacting with the current time and sleeping, as well as some time-related+data types and classes.+-}+module Polysemy.Time (+  -- $intro+  -- * Time effect+  module Polysemy.Time.Data.Time,+  GhcTime,+  -- * Interpreters+  interpretTimeGhc,+  interpretTimeGhcAt,+  -- * Data types+  module Polysemy.Time.Data.TimeUnit,+  module Polysemy.Time.Calendar,+) where++import Polysemy.Time.Calendar (+  Calendar(..),+  HasDay(..),+  HasHour(..),+  HasMinute(..),+  HasMonth(..),+  HasNanoSecond(..),+  HasSecond(..),+  HasYear(..),+  )+import Polysemy.Time.Data.Time (Time(..), now, setDate, setTime, sleep, today)+import Polysemy.Time.Data.TimeUnit (+  Days(Days),+  Hours(Hours),+  MicroSeconds(MicroSeconds),+  MilliSeconds(MilliSeconds),+  Minutes(Minutes),+  Months(Months),+  NanoSeconds(NanoSeconds),+  Seconds(Seconds),+  TimeUnit,+  Weeks(Weeks),+  Years(Years),+  convert,+  )+import Polysemy.Time.Ghc (GhcTime, interpretTimeGhc, interpretTimeGhcAt)+import Polysemy.Time.Orphans ()++{- $intro+@+import Data.Time (UTCTime)+import Polysemy (Members, runM)+import Polysemy.Chronos (interpretTimeChronos)+import qualified Polysemy.Time as Time+import Polysemy.Time (MilliSeconds(MilliSeconds), Seconds(Seconds), Time, interpretTimeGhcAt, mkDatetime, year)++prog ::+  Ord t =>+  Member (Time t d) r =>+  Sem r ()+prog = do+  time1 \<- Time.now+  Time.sleep (MilliSeconds 10)+  time2 \<- Time.now+  print (time1 \< time2)+  -- True++testTime :: UTCTime+testTime =+  mkDatetime 1845 12 31 23 59 59++main :: IO ()+main =+  runM do+    interpretTimeChronos prog+    interpretTimeGhcAt testTime do+      Time.sleep (Seconds 1)+      time \<- Time.now+      print (year time)+      -- Years { unYear = 1846 }+@+-}
+ lib/Polysemy/Time/At.hs view
@@ -0,0 +1,59 @@+module Polysemy.Time.At where++import Polysemy (intercept)+import Torsor (Torsor(add), difference)++import Polysemy.Time.Calendar (HasDate, date, dateToTime)+import qualified Polysemy.Time.Data.Time as Time+import Polysemy.Time.Data.Time (Time)++-- |Determine the current time adjusted for the difference between a custom instant and the time at which the program+-- was started.+dateCurrentRelative ::+  ∀ diff t d r .+  Torsor t diff =>+  Members [Time t d, Embed IO, State (t, t)] r =>+  Sem r t+dateCurrentRelative = do+  (startAt, startActual) <- get @(t, t)+  (`add` startAt) . (`difference` startActual) <$> Time.now @t @d++-- |Given real and adjusted start time, change all calls to 'Time.Now' and 'Time.Today' to be relative to that start+-- time.+-- This needs to be interpreted with a vanilla interpreter for 'Time' once more.+interpretTimeAtWithStart ::+  ∀ diff t d r a .+  Torsor t diff =>+  HasDate t d =>+  Members [Time t d, Embed IO, State (t, t)] r =>+  Sem r a ->+  Sem r a+interpretTimeAtWithStart =+  intercept @(Time t d) \case+    Time.Now ->+      dateCurrentRelative @diff @t @d+    Time.Today ->+      date <$> dateCurrentRelative @diff @t @d+    Time.Sleep t ->+      Time.sleep @t @d t+    Time.SetTime startAt -> do+      startActual <- Time.now @t @d+      put @(t, t) (startAt, startActual)+    Time.SetDate startAt -> do+      startActual <- Time.now @t @d+      put @(t, t) (dateToTime startAt, startActual)+{-# INLINE interpretTimeAtWithStart #-}++-- |Interpret 'Time' so that the time when the program starts is @startAt@.+interpretTimeAt ::+  ∀ (diff :: *) t d r a .+  Torsor t diff =>+  HasDate t d =>+  Members [Time t d, Embed IO] r =>+  t ->+  Sem r a ->+  Sem r a+interpretTimeAt startAt sem = do+  startActual <- Time.now @t @d+  evalState (startAt, startActual) . interpretTimeAtWithStart @diff @t @d . raise $ sem+{-# INLINE interpretTimeAt #-}
+ lib/Polysemy/Time/Calendar.hs view
@@ -0,0 +1,129 @@+module Polysemy.Time.Calendar where++import Data.Time (+  Day,+  DiffTime,+  TimeOfDay(TimeOfDay),+  UTCTime(UTCTime),+  fromGregorian,+  timeOfDayToTime,+  timeToTimeOfDay,+  toGregorian,+  utctDay,+  )+import Prelude hiding (second)++import Polysemy.Time.Data.TimeUnit (Days, Hours, Minutes, Months, NanoSeconds, Seconds, Years, convert)++-- |Utility for 'Polysemy.Time.At.interpretTimeAtWithStart'.+class HasDate t d | t -> d where+  date :: t -> d+  dateToTime :: d -> t++-- |Extract the year component from a date.+class HasYear t where+  year :: t -> Years++-- |Extract the month component from a date.+class HasMonth t where+  month :: t -> Months++-- |Extract the day component from a date.+class HasDay t where+  day :: t -> Days++-- |Extract the hour component from a datetime or time.+class HasHour t where+  hour :: t -> Hours++-- |Extract the minute component from a datetime or time.+class HasMinute t where+  minute :: t -> Minutes++-- |Extract the second component from a datetime or time.+class HasSecond t where+  second :: t -> Seconds++-- |Extract the nanosecond component from a datetime or time.+class HasNanoSecond t where+  nanoSecond :: t -> NanoSeconds++-- |Construct datetimes, dates or times from integers.+class Calendar dt where+  type CalendarDate dt :: *+  type CalendarTime dt :: *+  mkDate :: Int64 -> Int64 -> Int64 -> CalendarDate dt+  mkTime :: Int64 -> Int64 -> Int64 -> CalendarTime dt+  mkDatetime :: Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> dt++instance HasDate UTCTime Day where+  date =+    utctDay+  dateToTime d =+    UTCTime d 0++instance HasYear Day where+  year (toGregorian -> (y, _, _)) =+    fromIntegral y++instance HasYear UTCTime where+  year =+    year . utctDay++instance HasMonth Day where+  month (toGregorian -> (_, m, _)) =+    fromIntegral m++instance HasMonth UTCTime where+  month =+    month . utctDay++instance HasDay Day where+  day (toGregorian -> (_, _, d)) =+    fromIntegral d++instance HasDay UTCTime where+  day =+    day . utctDay++instance HasHour TimeOfDay where+  hour (TimeOfDay h _ _) =+    fromIntegral h++instance HasHour DiffTime where+  hour =+    hour . timeToTimeOfDay++instance HasMinute TimeOfDay where+  minute (TimeOfDay _ m _) =+    fromIntegral m++instance HasMinute DiffTime where+  minute =+    minute . timeToTimeOfDay++instance HasSecond TimeOfDay where+  second (TimeOfDay _ _ s) =+    truncate s++instance HasSecond DiffTime where+  second =+    second . timeToTimeOfDay++instance HasNanoSecond TimeOfDay where+  nanoSecond t =+    convert (second t)++instance HasNanoSecond DiffTime where+  nanoSecond =+    nanoSecond . timeToTimeOfDay++instance Calendar UTCTime where+  type CalendarDate UTCTime = Day+  type CalendarTime UTCTime = DiffTime+  mkDate y m d =+    fromGregorian (fromIntegral y) (fromIntegral m) (fromIntegral d)+  mkTime h m s =+    timeOfDayToTime (TimeOfDay (fromIntegral h) (fromIntegral m) (fromIntegral s))+  mkDatetime y mo d h mi s =+    UTCTime (mkDate @UTCTime y mo d) (mkTime @UTCTime h mi s)
+ lib/Polysemy/Time/Data/Time.hs view
@@ -0,0 +1,18 @@+module Polysemy.Time.Data.Time where++import Polysemy.Time.Data.TimeUnit (TimeUnit)++-- |The Time effect.+data Time (time :: *) (date :: *) :: Effect where+  -- |Produce the current time, possibly relative to what was set with 'SetTime' or 'SetDate'+  Now :: Time t d m t+  -- |Produce the current date, possibly relative to what was set with 'SetTime' or 'SetDate'+  Today :: Time t d m d+  -- |Suspend the current computation for the specified time span.+  Sleep :: TimeUnit u => u -> Time t d m ()+  -- |Set the current time, if the interpreter supports it.+  SetTime :: t -> Time t d m ()+  -- |Set the current date, if the interpreter supports it.+  SetDate :: d -> Time t d m ()++makeSem ''Time
+ lib/Polysemy/Time/Data/TimeUnit.hs view
@@ -0,0 +1,160 @@+module Polysemy.Time.Data.TimeUnit where++import Data.Time (+  DiffTime,+  NominalDiffTime,+  diffTimeToPicoseconds,+  nominalDiffTimeToSeconds,+  picosecondsToDiffTime,+  secondsToNominalDiffTime,+  )+import Torsor (Additive, Scaling, scale)++-- |Types that represent an amount of time that can be converted to each other.+-- The methods are internal, the API function is 'convert'.+class TimeUnit t where+  nanos :: NanoSeconds++  toNanos :: t -> NanoSeconds+  default toNanos :: Integral t => t -> NanoSeconds+  toNanos t =+    scale (fromIntegral t) (nanos @t)++  fromNanos :: NanoSeconds -> t+  default fromNanos :: Integral t => NanoSeconds -> t+  fromNanos n =+    fromIntegral (n `div` (fromIntegral (nanos @t)))++-- * Data types used to specify time spans, e.g. for sleeping.++newtype Years =+  Years { unYear :: Int64 }+  deriving (Eq, Show, Generic)+  deriving newtype (Num, Real, Enum, Integral, Ord, Additive)++newtype Months =+  Months { unMonths :: Int64 }+  deriving (Eq, Show, Generic)+  deriving newtype (Num, Real, Enum, Integral, Ord, Additive)++newtype Weeks =+  Weeks { unWeeks :: Int64 }+  deriving (Eq, Show, Generic)+  deriving newtype (Num, Real, Enum, Integral, Ord, Additive)++instance TimeUnit Weeks where+  nanos =+    NanoSeconds 604800000000000++newtype Days =+  Days { unDays :: Int64 }+  deriving (Eq, Show, Generic)+  deriving newtype (Num, Real, Enum, Integral, Ord, Additive)++instance TimeUnit Days where+  nanos =+    NanoSeconds 86400000000000++newtype Hours =+  Hours { unHours :: Int64 }+  deriving (Eq, Show, Generic)+  deriving newtype (Num, Real, Enum, Integral, Ord, Additive)++instance TimeUnit Hours where+  nanos =+    NanoSeconds 3600000000000++newtype Minutes =+  Minutes { unMinutes :: Int64 }+  deriving (Eq, Show, Generic)+  deriving newtype (Num, Real, Enum, Integral, Ord, Additive)++instance TimeUnit Minutes where+  nanos =+    NanoSeconds 60000000000++newtype Seconds =+  Seconds { unSeconds :: Int64 }+  deriving (Eq, Show, Generic)+  deriving newtype (Num, Real, Enum, Integral, Ord, Additive)++instance TimeUnit Seconds where+  nanos =+    NanoSeconds 1000000000++newtype MilliSeconds =+  MilliSeconds { unMilliSeconds :: Int64 }+  deriving (Eq, Show, Generic)+  deriving newtype (Num, Real, Enum, Integral, Ord, Additive)++instance TimeUnit MilliSeconds where+  nanos =+    NanoSeconds 1000000++newtype MicroSeconds =+  MicroSeconds { unMicroSeconds :: Int64 }+  deriving (Eq, Show, Generic)+  deriving newtype (Num, Real, Enum, Integral, Ord, Additive)++instance TimeUnit MicroSeconds where+  nanos =+    NanoSeconds 1000++newtype NanoSeconds =+  NanoSeconds { unNanoSeconds :: Int64 }+  deriving (Eq, Show, Generic)+  deriving newtype (Num, Real, Enum, Integral, Ord, Additive)++instance Scaling NanoSeconds Int64 where+  scale s (NanoSeconds v) =+    NanoSeconds (scale s v)++instance TimeUnit NanoSeconds where+  nanos =+    NanoSeconds 1+  toNanos =+    id+  fromNanos =+    id++instance TimeUnit DiffTime where+  nanos =+    0+  toNanos dt =+    NanoSeconds (divOr0 (fromIntegral (diffTimeToPicoseconds dt)) 1000)+  fromNanos (NanoSeconds ns) =+    picosecondsToDiffTime (fromIntegral ns * 1000)++instance TimeUnit NominalDiffTime where+  nanos =+    0+  toNanos dt =+    NanoSeconds (divOr0 (fromIntegral (fromEnum (nominalDiffTimeToSeconds dt))) 1000)+  fromNanos (NanoSeconds ns) =+    secondsToNominalDiffTime (toEnum (fromIntegral ns) * 1000)++-- |Convert between different time spans.+--+-- >>> convert (picosecondsToDiffTime 50000000) :: MicroSeconds+-- MicroSeconds {unMicroSeconds = 50}+--+-- >>> convert (MilliSeconds 5) :: MicroSeconds+-- MicroSeconds 5000+convert ::+  TimeUnit a =>+  TimeUnit b =>+  a ->+  b+convert =+  fromNanos . toNanos++defaultJson ''Years+defaultJson ''Months+defaultJson ''Weeks+defaultJson ''Days+defaultJson ''Hours+defaultJson ''Minutes+defaultJson ''Seconds+defaultJson ''MilliSeconds+defaultJson ''MicroSeconds+defaultJson ''NanoSeconds
+ lib/Polysemy/Time/Debug.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Polysemy.Time.Debug where++import Data.String.Interpolate (i)+import qualified Data.Text as Text+import GHC.Stack (SrcLoc(..))+import Relude+import System.IO.Unsafe (unsafePerformIO)++srcLoc :: CallStack -> SrcLoc+srcLoc = \case+  (getCallStack -> (_, loc) : _) -> loc+  _ -> error "Debug.srcLoc: empty CallStack"++debugPrint ::+  SrcLoc ->+  Text ->+  IO ()+debugPrint SrcLoc{ srcLocModule = (toText -> slm), ..} msg =+  putStrLn [i|#{moduleName}:#{srcLocStartLine} #{msg}|]+  where+    moduleName =+      fromMaybe slm $ listToMaybe $ reverse $ Text.splitOn "." slm++debugPrintWithLoc ::+  Monad m =>+  SrcLoc ->+  Text ->+  m ()+debugPrintWithLoc loc msg = do+  () <- return (unsafePerformIO (debugPrint loc msg))+  pure ()++dbg ::+  HasCallStack =>+  Monad m =>+  Text ->+  m ()+dbg =+  debugPrintWithLoc (srcLoc callStack)+{-# inline dbg #-}++dbgsWith ::+  HasCallStack =>+  Monad m =>+  Show a =>+  Text ->+  a ->+  m ()+dbgsWith prefix a =+  debugPrintWithLoc (srcLoc callStack) [i|#{prefix}: #{show @Text a}|]+{-# inline dbgsWith #-}++dbgs ::+  HasCallStack =>+  Monad m =>+  Show a =>+  a ->+  m ()+dbgs a =+  debugPrintWithLoc (srcLoc callStack) (show a)+{-# inline dbgs_ #-}++dbgs_ ::+  HasCallStack =>+  Monad m =>+  Show a =>+  a ->+  m a+dbgs_ a =+  a <$ debugPrintWithLoc (srcLoc callStack) (show a)+{-# inline dbgs #-}++tr ::+  HasCallStack =>+  Text ->+  a ->+  a+tr msg a =+  unsafePerformIO (a <$ debugPrint (srcLoc callStack) msg)+{-# INLINE tr #-}++trs ::+  Show a =>+  HasCallStack =>+  a ->+  a+trs a =+  unsafePerformIO (a <$ debugPrint (srcLoc callStack) (show a))+{-# INLINE trs #-}++trs' ::+  Show b =>+  HasCallStack =>+  b ->+  a ->+  a+trs' b a =+  unsafePerformIO (a <$ debugPrint (srcLoc callStack) (show b))+{-# INLINE trs' #-}
+ lib/Polysemy/Time/Ghc.hs view
@@ -0,0 +1,46 @@+module Polysemy.Time.Ghc where++import Control.Concurrent (threadDelay)+import Data.Time (Day, NominalDiffTime, UTCTime, utctDay)+import Data.Time.Clock.System (getSystemTime, systemToUTCTime)++import Polysemy.Time.At (interpretTimeAt)+import qualified Polysemy.Time.Data.Time as Time+import Polysemy.Time.Data.Time (Time)+import Polysemy.Time.Data.TimeUnit (MicroSeconds(MicroSeconds), convert)+import Polysemy.Time.Orphans ()++-- |Convenience alias for 'Data.Time'.+type GhcTime =+  Time UTCTime Day++now ::+  Member (Embed IO) r =>+  Sem r UTCTime+now =+  systemToUTCTime <$> embed getSystemTime++-- |Interpret 'Time' with the types from 'Data.Time'.+interpretTimeGhc ::+  Member (Embed IO) r =>+  InterpreterFor GhcTime r+interpretTimeGhc =+  interpret \case+    Time.Now ->+      now+    Time.Today ->+      utctDay <$> now+    Time.Sleep (convert -> MicroSeconds us) ->+      embed (threadDelay (fromIntegral us))+    Time.SetTime _ ->+      unit+    Time.SetDate _ ->+      unit++-- |Interpret 'Time' with the types from 'Data.Time', customizing the current time at the start of interpretation.+interpretTimeGhcAt ::+  Member (Embed IO) r =>+  UTCTime ->+  InterpreterFor GhcTime r+interpretTimeGhcAt =+  interpretTimeGhc .: interpretTimeAt @NominalDiffTime
+ lib/Polysemy/Time/Orphans.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Polysemy.Time.Orphans where++import Data.Time (secondsToNominalDiffTime, nominalDiffTimeToSeconds, diffUTCTime, addUTCTime, NominalDiffTime, UTCTime)+import Torsor (Additive(..), Torsor(..))++instance Additive NominalDiffTime where+  zero =+    0+  invert =+    secondsToNominalDiffTime . negate . nominalDiffTimeToSeconds+  plus =+    (+)+  minus =+    (-)++instance Torsor UTCTime NominalDiffTime where+  add v p =+    addUTCTime v p+  difference =+    diffUTCTime
+ lib/Polysemy/Time/Prelude.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Polysemy.Time.Prelude (+  module Polysemy.Time.Prelude,+  module Data.Aeson,+  module Data.Aeson.TH,+  module Data.Composition,+  module Data.Default,+  module Data.Either.Combinators,+  module Data.Foldable,+  module Data.List.NonEmpty,+  module Data.Map.Strict,+  module GHC.Err,+  module GHC.TypeLits,+  module Polysemy,+  module Polysemy.AtomicState,+  module Polysemy.Time.Debug,+  module Polysemy.Error,+  module Polysemy.Internal.Bundle,+  module Polysemy.Reader,+  module Polysemy.State,+  module Relude,+) where++import Control.Exception (throwIO, try)+import qualified Data.Aeson as Aeson+import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON))+import Data.Aeson.TH (deriveFromJSON, deriveJSON)+import Data.Composition ((.:), (.:.), (.::))+import Data.Default (Default(def))+import Data.Either.Combinators (mapLeft)+import Data.Fixed (div')+import Data.Foldable (foldl, traverse_)+import Data.List.NonEmpty ((<|))+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map, lookup)+import qualified Data.Text as Text+import GHC.Err (undefined)+import GHC.IO.Unsafe (unsafePerformIO)+import GHC.TypeLits (Symbol)+import qualified Language.Haskell.TH.Syntax as TH+import Polysemy (+  Effect,+  EffectRow,+  Embed,+  Final,+  InterpreterFor,+  Member,+  Members,+  Sem,+  WithTactics,+  embed,+  embedToFinal,+  interpret,+  makeSem,+  pureT,+  raise,+  raiseUnder,+  raiseUnder2,+  raiseUnder3,+  reinterpret,+  runFinal,+  )+import Polysemy.AtomicState (AtomicState, atomicGet, atomicGets, atomicModify', atomicPut, runAtomicStateTVar)+import Polysemy.Error (Error, fromEither, mapError, note, runError, throw)+import Polysemy.Internal.Bundle (Append)+import Polysemy.Reader (Reader)+import Polysemy.State (State, evalState, get, gets, modify, modify', put, runState)+import Polysemy.Time.Debug (dbg, dbgs, dbgs_)+import Relude hiding (+  Reader,+  State,+  Sum,+  Type,+  ask,+  asks,+  evalState,+  filterM,+  get,+  gets,+  hoistEither,+  modify,+  modify',+  put,+  readFile,+  runReader,+  runState,+  state,+  trace,+  traceShow,+  undefined,+  )+import System.IO.Error (userError)++unit ::+  Applicative f =>+  f ()+unit =+  pure ()+{-# inline unit #-}++tuple ::+  Applicative f =>+  f a ->+  f b ->+  f (a, b)+tuple fa fb =+  (,) <$> fa <*> fb+{-# inline tuple #-}++unsafeLogSAnd :: Show a => a -> b -> b+unsafeLogSAnd a b =+  unsafePerformIO $ print a >> return b+{-# inline unsafeLogSAnd #-}++unsafeLogAnd :: Text -> b -> b+unsafeLogAnd a b =+  unsafePerformIO $ putStrLn (toString a) >> return b+{-# inline unsafeLogAnd #-}++unsafeLogS :: Show a => a -> a+unsafeLogS a =+  unsafePerformIO $ print a >> return a+{-# inline unsafeLogS #-}++unsafeLog :: Text -> Text+unsafeLog a =+  unsafePerformIO $ putStrLn (toString a) >> return a+{-# inline unsafeLog #-}++liftT ::+  forall m f r e a .+  Functor f =>+  Sem r a ->+  Sem (WithTactics e f m r) (f a)+liftT =+  pureT <=< raise+{-# inline liftT #-}++hoistEither ::+  Member (Error e2) r =>+  (e1 -> e2) ->+  Either e1 a ->+  Sem r a+hoistEither f =+  fromEither . mapLeft f+{-# inline hoistEither #-}++hoistEitherWith ::+  (e -> Sem r a) ->+  Either e a ->+  Sem r a+hoistEitherWith f =+  either f pure+{-# inline hoistEitherWith #-}++hoistEitherShow ::+  Show e1 =>+  Member (Error e2) r =>+  (Text -> e2) ->+  Either e1 a ->+  Sem r a+hoistEitherShow f =+  fromEither . mapLeft (f . Text.replace "\\" "" . show)+{-# inline hoistEitherShow #-}++hoistErrorWith ::+  (e -> Sem r a) ->+  Sem (Error e : r) a ->+  Sem r a+hoistErrorWith f =+  hoistEitherWith f <=< runError+{-# inline hoistErrorWith #-}++tryAny ::+  Member (Embed IO) r =>+  IO a ->+  Sem r (Either Text a)+tryAny =+  embed . fmap (mapLeft show) . try @SomeException+{-# inline tryAny #-}++tryHoist ::+  Member (Embed IO) r =>+  (Text -> e) ->+  IO a ->+  Sem r (Either e a)+tryHoist f =+  fmap (mapLeft f) . tryAny+{-# inline tryHoist #-}++tryThrow ::+  Members [Embed IO, Error e] r =>+  (Text -> e) ->+  IO a ->+  Sem r a+tryThrow f =+  fromEither <=< tryHoist f+{-# inline tryThrow #-}++throwTextIO :: Text -> IO a+throwTextIO =+  throwIO . userError . toString+{-# inline throwTextIO #-}++throwEitherIO :: Either Text a -> IO a+throwEitherIO =+  traverseLeft throwTextIO+{-# inline throwEitherIO #-}++basicOptions :: Aeson.Options+basicOptions =+  Aeson.defaultOptions {+    Aeson.fieldLabelModifier = dropWhile ('_' ==)+  }++jsonOptions :: Aeson.Options+jsonOptions =+  basicOptions {+    Aeson.unwrapUnaryRecords = True+  }++defaultJson :: TH.Name -> TH.Q [TH.Dec]+defaultJson =+  deriveJSON jsonOptions+{-# inline defaultJson #-}++unaryRecordJson :: TH.Name -> TH.Q [TH.Dec]+unaryRecordJson =+  deriveJSON basicOptions+{-# inline unaryRecordJson #-}++type Basic a =+  (Eq a, Show a)++type family Basics (as :: [*]) :: Constraint where+  Basics '[] = ()+  Basics (a : as) = (Basic a, Basics as)++type Eso a =+  (Basic a, Ord a)++type family Esos (as :: [*]) :: Constraint where+  Esos '[] = ()+  Esos (a : as) = (Eso a, Esos as)++type Json a =+  (FromJSON a, ToJSON a, Basic a)++type family Jsons (r :: [*]) :: Constraint where+  Jsons '[] = ()+  Jsons (a ': r) = (Json a, Jsons r)++type a ++ b =+  Append a b++rightOr :: (a -> b) -> Either a b -> b+rightOr f =+  either f id+{-# inline rightOr #-}++traverseLeft ::+  Applicative m =>+  (a -> m b) ->+  Either a b ->+  m b+traverseLeft f =+  either f pure+{-# inline traverseLeft #-}++jsonDecode ::+  FromJSON a =>+  ByteString ->+  Either Text a+jsonDecode =+  mapLeft toText . Aeson.eitherDecodeStrict'+{-# inline jsonDecode #-}++jsonDecodeL ::+  FromJSON a =>+  LByteString ->+  Either Text a+jsonDecodeL =+  mapLeft toText . Aeson.eitherDecode'+{-# inline jsonDecodeL #-}++jsonDecodeText ::+  FromJSON a =>+  Text ->+  Either Text a+jsonDecodeText =+  mapLeft toText . Aeson.eitherDecodeStrict' . encodeUtf8+{-# inline jsonDecodeText #-}++jsonEncode ::+  ToJSON a =>+  a ->+  ByteString+jsonEncode =+  toStrict . Aeson.encode+{-# inline jsonEncode #-}++jsonEncodeText ::+  ToJSON a =>+  a ->+  Text+jsonEncodeText =+  decodeUtf8 . jsonEncode+{-# inline jsonEncodeText #-}++as ::+  Functor m =>+  a ->+  m b ->+  m a+as =+  (<$)+{-# inline as #-}++mneToList :: Maybe (NonEmpty a) -> [a]+mneToList =+  maybe [] toList+{-# inline mneToList #-}++safeDiv ::+  Eq a =>+  Real a =>+  Integral a =>+  a ->+  a ->+  Maybe a+safeDiv _ 0 =+  Nothing+safeDiv n d =+  Just (n `div'` d)+{-# inline safeDiv #-}++divOr0 ::+  Eq a =>+  Real a =>+  Integral a =>+  a ->+  a ->+  a+divOr0 =+  fromMaybe 0 .: safeDiv+{-# inline divOr0 #-}++mapBy ::+  Ord k =>+  (a -> k) ->+  [a] ->+  Map k a+mapBy f =+  Map.fromList . fmap \ a -> (f a, a)
+ lib/Polysemy/Time/Sleep.hs view
@@ -0,0 +1,20 @@+module Polysemy.Time.Sleep where++import Control.Concurrent (threadDelay)++import Polysemy.Time.Data.TimeUnit (MicroSeconds(MicroSeconds), TimeUnit, convert)++uSleep ::+  Member (Embed IO) r =>+  MicroSeconds ->+  Sem r ()+uSleep (MicroSeconds us) =+  embed (threadDelay (fromIntegral us))++tSleep ::+  Member (Embed IO) r =>+  TimeUnit t =>+  t ->+  Sem r ()+tSleep =+  uSleep . convert
+ lib/Prelude.hs view
@@ -0,0 +1,5 @@+module Prelude (+  module Polysemy.Time.Prelude,+) where++import Polysemy.Time.Prelude
+ polysemy-time.cabal view
@@ -0,0 +1,99 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.34.2.+--+-- see: https://github.com/sol/hpack++name:           polysemy-time+version:        0.1.0.0+synopsis:       Polysemy effect for time+description:    Please see the readme on Github at <https://github.com/tek/polysemy-time>+category:       Time+author:         Torsten Schmits+maintainer:     tek@tryp.io+copyright:      2020 Torsten Schmits+license:        BSD-2-Clause-Patent+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    readme.md+    changelog.md++library+  exposed-modules:+      Polysemy.Time+      Polysemy.Time.At+      Polysemy.Time.Calendar+      Polysemy.Time.Data.Time+      Polysemy.Time.Data.TimeUnit+      Polysemy.Time.Debug+      Polysemy.Time.Ghc+      Polysemy.Time.Orphans+      Polysemy.Time.Prelude+      Polysemy.Time.Sleep+      Paths_polysemy_time+  other-modules:+      Prelude+  autogen-modules:+      Paths_polysemy_time+  hs-source-dirs:+      lib+  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia DisambiguateRecordFields DoAndIfThenElse DuplicateRecordFields EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase LiberalTypeSynonyms MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings OverloadedLists PackageImports PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds QuantifiedConstraints QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns+  ghc-options: -flate-specialise -fspecialise-aggressively -Wall+  build-depends:+      aeson >=1.4 && <1.5+    , base >=4 && <5+    , composition >=1.0 && <1.1+    , containers+    , data-default >=0.7 && <0.8+    , either+    , polysemy >=1.3.0 && <1.4+    , relude >=0.7 && <0.8+    , string-interpolate >=0.1 && <0.4+    , template-haskell+    , text+    , time+    , torsor >=0.1 && <0.2+  mixins:+      base hiding (Prelude)+  if impl(ghc < 8.10)+    ghc-options: -O2+  default-language: Haskell2010++test-suite polysemy-time-unit+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Polysemy.Time.GhcTimeTest+      Paths_polysemy_time+  hs-source-dirs:+      test+  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia DisambiguateRecordFields DoAndIfThenElse DuplicateRecordFields EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase LiberalTypeSynonyms MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings OverloadedLists PackageImports PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds QuantifiedConstraints QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns+  ghc-options: -flate-specialise -fspecialise-aggressively -Wall -threaded -rtsopts -with-rtsopts=-N -fplugin=Polysemy.Plugin+  build-depends:+      aeson >=1.4 && <1.5+    , base >=4 && <5+    , composition >=1.0 && <1.1+    , containers+    , data-default >=0.7 && <0.8+    , either+    , hedgehog+    , polysemy >=1.3.0 && <1.4+    , polysemy-plugin+    , polysemy-test+    , polysemy-time+    , relude >=0.7 && <0.8+    , string-interpolate >=0.1 && <0.4+    , tasty+    , tasty-hedgehog+    , template-haskell+    , text+    , time+    , torsor >=0.1 && <0.2+  mixins:+      base hiding (Prelude)+    , polysemy-time hiding (Prelude)+    , polysemy-time (Polysemy.Time.Prelude as Prelude)+  if impl(ghc < 8.10)+    ghc-options: -O2+  default-language: Haskell2010
+ readme.md view
@@ -0,0 +1,89 @@+# About++This Haskell library provides a [Polysemy] effect for accessing the current+time and date and an implementation for [time] and [chronos].++# Example++```haskell+import Data.Time (UTCTime)+import Polysemy (Members, runM)+import Polysemy.Chronos (interpretTimeChronos)+import qualified Polysemy.Time as Time+import Polysemy.Time (MilliSeconds(MilliSeconds), Seconds(Seconds), Time, interpretTimeGhcAt, mkDatetime, year)++prog ::+  Ord t =>+  Member (Time t d) r =>+  Sem r ()+prog = do+  time1 <- Time.now+  Time.sleep (MilliSeconds 10)+  time2 <- Time.now+  print (time1 < time2)+  -- True++testTime :: UTCTime+testTime =+  mkDatetime 1845 12 31 23 59 59++main :: IO ()+main =+  runM do+    interpretTimeChronos prog+    interpretTimeGhcAt testTime do+      Time.sleep (Seconds 1)+      time <- Time.now+      print (year time)+      -- Years { unYear = 1846 }+```++# Effect++The only effect contained in **polysemy-time** is:++```haskell+data Time (time :: *) (date :: *) :: Effect where+  Now :: Time t d m t+  Today :: Time t d m d+  Sleep :: TimeUnit u => u -> Time t d m ()+  SetTime :: t -> Time t d m ()+  SetDate :: d -> Time t d m ()+```++Interpreters are provided for the [time library](time) bundled with GHC and [chronos].++The type parameters correspond to the representations in the implementation,+like `Data.Time.UTCTime`/`Chronos.Time` and `Data.Time.Day`/`Chronos.Date`.++`SetTime` and `SetDate` only have meaning when you're running in a testing context.++A special interpreter variant suffixed with `At` exists for both+implementations, with which the current time is overridden to be relative to+the supplied override fixed at the start of interpretation.+This is useful for testing.++# Utilities++A set of newtypes representing timespans are provided for convenience.+Internally, the interpreters operate on `NanoSecond`s.++The class `TimeUnit` ties those types, and the types `Chronos.Timespan` and+`Data.Time.DiffTime`, together to allow you to convert between them with the+function `convert`:++```haskell+>>> convert (picosecondsToDiffTime 50000000) :: MicroSeconds+MicroSeconds {unMicroSeconds = 50}++>>> convert (Days 5) :: Timespan+Timespan {getTimespan = 432000000000000}+```++The class `Calendar` allows you to construct `UTCTime` and `Chronos.Datetime`+from integers with the function `mkDatetime`, as demonstrated in the first+example.++[Polysemy]: https://hackage.haskell.org/package/polysemy+[time]: https://hackage.haskell.org/package/time+[chronos]: https://hackage.haskell.org/package/chronos
+ test/Main.hs view
@@ -0,0 +1,16 @@+module Main where++import Polysemy.Test (unitTest)+import Polysemy.Time.GhcTimeTest (test_ghcTime, test_ghcTimeAt)+import Test.Tasty (TestTree, defaultMain, testGroup)++tests :: TestTree+tests =+  testGroup "unit" [+    unitTest "ghc time" test_ghcTime,+    unitTest "ghc time at instant" test_ghcTimeAt+  ]++main :: IO ()+main =+  defaultMain tests
+ test/Polysemy/Time/GhcTimeTest.hs view
@@ -0,0 +1,36 @@+module Polysemy.Time.GhcTimeTest where++import Data.Time (Day, UTCTime)++import Polysemy.Test (UnitTest, assert, runTestAuto, (===))+import Polysemy.Test.Data.Hedgehog (Hedgehog)+import Polysemy.Time (Time, mkDatetime, year)+import qualified Polysemy.Time.Data.Time as Time+import Polysemy.Time.Data.TimeUnit (Seconds(Seconds))+import Polysemy.Time.Ghc (interpretTimeGhc, interpretTimeGhcAt)++prog ::+  Ord t =>+  Members [Time t d, Hedgehog IO] r =>+  Sem r ()+prog = do+  time1 <- Time.now+  time2 <- Time.now+  assert (time1 < time2)++test_ghcTime :: UnitTest+test_ghcTime =+  runTestAuto do+    interpretTimeGhc prog++testTime :: UTCTime+testTime =+  mkDatetime 1845 12 31 23 59 59++test_ghcTimeAt :: UnitTest+test_ghcTimeAt =+  runTestAuto do+    interpretTimeGhcAt testTime do+      Time.sleep @UTCTime @Day (Seconds 1)+      time <- Time.now+      1846 === year time