data-timeout 0.2 → 0.3
raw patch · 2 files changed
+123/−32 lines, 2 filesdep +data-textualdep +parsersdep +tagged
Dependencies added: data-textual, parsers, tagged, text-printer
Files
- data-timeout.cabal +5/−1
- src/Data/Timeout.hs +118/−31
data-timeout.cabal view
@@ -1,5 +1,5 @@ Name: data-timeout-Version: 0.2+Version: 0.3 Category: Data, Concurrency Stability: experimental Synopsis: 64-bit timeouts of nanosecond precision@@ -26,6 +26,10 @@ Library Build-Depends: base >= 4 && < 5,+ tagged >= 0.2,+ text-printer >= 0.4,+ data-textual >= 0.2,+ parsers >= 0.5, transformers-base >= 0.3 Hs-Source-Dirs: src GHC-Options: -Wall
src/Data/Timeout.hs view
@@ -2,21 +2,34 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Data.Timeout (- TimedOut(..),- TimeoutUnit(..),- timeoutUnitNanos,- Timeout(..),- (#),- (#>),- (#<),- instantly+module Data.Timeout+ ( TimedOut(..)+ , TimeoutUnit(..)+ , aTimeoutUnit+ , timeoutUnitNanos+ , Timeout(..)+ , aTimeout+ , (#)+ , (#>)+ , (#<)+ , instantly ) where +import Prelude hiding (print) import Data.Typeable (Typeable) import Data.Ix (Ix) import Data.Word (Word64)-import Data.List (intercalate)+import Data.Proxy (Proxy(..))+import Data.Monoid (mconcat)+import Data.Textual (Printable(..), Textual(..))+import qualified Data.Textual as DT+import Data.Textual.Fractional (Sign(..), Decimal(..), Optional(..),+ fractional')+import Text.Printer (Printer(char7, string7), (<>))+import Text.Parser.Combinators ((<?>), unexpected)+import qualified Text.Parser.Char as PC+import Control.Applicative+import Control.Monad (when) import Control.Exception (Exception) -- | Exception that is raised when an operation times out.@@ -35,8 +48,35 @@ | Hour | Day | Week- deriving (Typeable, Eq, Ord, Bounded, Ix, Enum)+ deriving (Typeable, Show, Read, Eq, Ord, Bounded, Ix, Enum) +-- | 'TimeoutUnit' proxy value.+aTimeoutUnit ∷ Proxy TimeoutUnit+aTimeoutUnit = Proxy++instance Printable TimeoutUnit where+ print NanoSecond = string7 "ns"+ print MicroSecond = string7 "us"+ print MilliSecond = string7 "ms"+ print Second = char7 's'+ print Minute = char7 'm'+ print Hour = char7 'h'+ print Day = char7 'd'+ print Week = char7 'w'+ {-# INLINABLE print #-}++instance Textual TimeoutUnit where+ textual = (<?> "timeout unit") $ do+ c ← PC.oneOf "numshdw" + case c of+ 'n' → PC.char 's' *> pure NanoSecond+ 'u' → PC.char 's' *> pure MicroSecond+ 'm' → maybe Minute (const MilliSecond) <$> optional (PC.char 's')+ 's' → pure Second+ 'h' → pure Hour+ 'd' → pure Day+ _ → pure Week+ -- | Amount of nanoseconds in a timeout unit. timeoutUnitNanos ∷ TimeoutUnit → Word64 timeoutUnitNanos NanoSecond = 1@@ -47,12 +87,47 @@ timeoutUnitNanos Hour = 60 * 60 * 1000000000 timeoutUnitNanos Day = 24 * 60 * 60 * 1000000000 timeoutUnitNanos Week = 7 * 24 * 60 * 60 * 1000000000-{-# INLINE timeoutUnitNanos #-}+{-# INLINABLE timeoutUnitNanos #-} --- | Timeout in nanoseconds.+-- | Timeout in nanoseconds. The 'Printable' instance renders timeouts as+-- series of /Amount/@Unit@ tokens, e.g.+--+-- @+-- 'DT.toString' (/1/ \# 'Day' + /1500/ \# 'MilliSecond') = /"1d1s500ms"/+-- @+--+-- The full list of timeout unit abbreviations:+-- +-- * 'NanoSecond' - /ns/+--+-- * 'MicroSecond' - /us/+--+-- * 'MilliSecond' - /ms/+--+-- * 'Second' - /s/+--+-- * 'Minute' - /m/+--+-- * 'Hour' - /h/+--+-- * 'Day' - /d/+--+-- * 'Week' - /w/+--+-- The 'Textual' instance accepts this syntax and allows decimal+-- fractions to be used as amounts:+--+-- @+-- 'fmap' 'DT.toString' ('DT.fromStringAs' 'aTimeout' /"1m1.5s0.2us"/) = 'Just' /"1m1s500ms200ns"/+-- @ newtype Timeout = Timeout Word64- deriving (Typeable, Eq, Ord, Bounded, Ix, Enum, Num, Real, Integral)+ deriving (Typeable, Show, Read, Eq, Ord, Bounded, Ix, Enum,+ Num, Real, Integral) +-- | 'Timeout' proxy value.+aTimeout ∷ Proxy Timeout+aTimeout = Proxy+ infix 9 # infix 8 #>, #< @@ -72,27 +147,39 @@ (Timeout tt) #< u = tt `quot` timeoutUnitNanos u {-# INLINE (#<) #-} -timeoutUnitAbbr ∷ TimeoutUnit → String-timeoutUnitAbbr NanoSecond = "ns"-timeoutUnitAbbr MicroSecond = "us"-timeoutUnitAbbr MilliSecond = "ms"-timeoutUnitAbbr Second = "s"-timeoutUnitAbbr Minute = "m"-timeoutUnitAbbr Hour = "h"-timeoutUnitAbbr Day = "d"-timeoutUnitAbbr Week = "w"--instance Show Timeout where- show (Timeout tt) =- if null ss then "instant" else intercalate " " (reverse ss)+instance Printable Timeout where+ print (Timeout tt) =+ if null ss then string7 "0ns" else mconcat (reverse ss) where ss = snd $ ($ enumFrom NanoSecond) $ (`foldr` (tt, [])) $ \u (t, ss') →- let (q, r) = t `quotRem` timeoutUnitNanos u- abbr = timeoutUnitAbbr u in- (r, if q == 0 then ss' else (show q ++ " " ++ abbr) : ss')+ let (q, r) = t `quotRem` timeoutUnitNanos u in+ (r, if q == 0 then ss' else (print q <> print u) : ss') +instance Textual Timeout where+ textual = (<?> "timeout") $ do+ a ← amount+ u ← textual+ let r = a * fromIntegral (timeoutUnitNanos u) ∷ Rational+ if u == minBound then result r else go u r+ where+ amount = fractional' (pure NonNegative) Decimal Required+ (PC.char '.' *> pure ()) (pure Nothing)+ go u r = do+ ma ← optional amount+ case ma of+ Nothing → result r+ Just a → do+ u' ← textual+ when (u' >= u) $ unexpected "timeout units must get smaller"+ let r' = r + a * fromIntegral (timeoutUnitNanos u')+ if u' == minBound then result r' else go u' r'+ result r = let c = ceiling r ∷ Integer in+ if (c ∷ Integer) > fromIntegral (maxBound ∷ Word64)+ then return maxBound+ else return $ Timeout $ fromIntegral c+ -- | Zero timeout. The event in question should occur immediately. instantly ∷ Timeout-instantly = 0 # NanoSecond+instantly = Timeout 0 {-# INLINE instantly #-}