more cost calculation and refactored Tunables

3 files changed, 217 insertions, 0 deletions

diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs
new file mode 100644
index 0000000..fe7cf22
--- /dev/null
+++ b/Utility/HumanTime.hs
@@ -0,0 +1,102 @@
+{- Time for humans.
+ -
+ - Copyright 2012-2013 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.HumanTime (
+	Duration(..),
+	durationSince,
+	durationToPOSIXTime,
+	durationToDays,
+	daysToDuration,
+	parseDuration,
+	fromDuration,
+	prop_duration_roundtrips
+) where
+
+import Utility.PartialPrelude
+import Utility.QuickCheck
+
+import qualified Data.Map as M
+import Data.Time.Clock
+import Data.Time.Clock.POSIX (POSIXTime)
+import Data.Char
+import Control.Applicative
+import Prelude
+
+newtype Duration = Duration { durationSeconds :: Integer }
+	deriving (Eq, Ord, Read, Show)
+
+durationSince :: UTCTime -> IO Duration
+durationSince pasttime = do
+	now <- getCurrentTime
+	return $ Duration $ round $ diffUTCTime now pasttime
+
+durationToPOSIXTime :: Duration -> POSIXTime
+durationToPOSIXTime = fromIntegral . durationSeconds
+
+durationToDays :: Duration -> Integer
+durationToDays d = durationSeconds d `div` dsecs
+
+daysToDuration :: Integer -> Duration
+daysToDuration i = Duration $ i * dsecs
+
+{- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -}
+parseDuration :: Monad m => String -> m Duration
+parseDuration = maybe parsefail (return . Duration) . go 0
+  where
+	go n [] = return n
+	go n s = do
+		num <- readish s :: Maybe Integer
+		case dropWhile isDigit s of
+			(c:rest) -> do
+				u <- M.lookup c unitmap
+				go (n + num * u) rest
+			_ -> return $ n + num
+	parsefail = fail "duration parse error; expected eg \"5m\" or \"1h5m\""
+
+fromDuration :: Duration -> String
+fromDuration Duration { durationSeconds = d }
+	| d == 0 = "0s"
+	| otherwise = concatMap showunit $ go [] units d
+  where
+	showunit (u, n)
+		| n > 0 = show n ++ [u]
+		| otherwise = ""
+	go c [] _ = reverse c
+	go c ((u, n):us) v =
+		let (q,r) = v `quotRem` n
+		in go ((u, q):c) us r
+
+units :: [(Char, Integer)]
+units = 
+	[ ('y', ysecs)
+	, ('d', dsecs)
+	, ('h', hsecs)
+	, ('m', msecs)
+	, ('s', 1)
+	]
+
+unitmap :: M.Map Char Integer
+unitmap = M.fromList units
+
+ysecs :: Integer
+ysecs = dsecs * 365
+
+dsecs :: Integer
+dsecs = hsecs * 24
+
+hsecs :: Integer
+hsecs = msecs * 60
+
+msecs :: Integer
+msecs = 60
+
+-- Durations cannot be negative.
+instance Arbitrary Duration where
+	arbitrary = Duration <$> nonNegative arbitrary
+
+prop_duration_roundtrips :: Duration -> Bool
+prop_duration_roundtrips d = parseDuration (fromDuration d) == Just d
diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs
new file mode 100644
index 0000000..5579556
--- /dev/null
+++ b/Utility/PartialPrelude.hs
@@ -0,0 +1,70 @@
+{- Parts of the Prelude are partial functions, which are a common source of
+ - bugs.
+ -
+ - This exports functions that conflict with the prelude, which avoids
+ - them being accidentially used.
+ -}
+
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.PartialPrelude where
+
+import qualified Data.Maybe
+
+{- read should be avoided, as it throws an error
+ - Instead, use: readish -}
+read :: Read a => String -> a
+read = Prelude.read
+
+{- head is a partial function; head [] is an error
+ - Instead, use: take 1 or headMaybe -}
+head :: [a] -> a
+head = Prelude.head
+
+{- tail is also partial
+ - Instead, use: drop 1 -}
+tail :: [a] -> [a]
+tail = Prelude.tail
+
+{- init too
+ - Instead, use: beginning -}
+init :: [a] -> [a]
+init = Prelude.init
+
+{- last too
+ - Instead, use: end or lastMaybe -}
+last :: [a] -> a
+last = Prelude.last
+
+{- Attempts to read a value from a String.
+ -
+ - Ignores leading/trailing whitespace, and throws away any trailing
+ - text after the part that can be read.
+ -
+ - readMaybe is available in Text.Read in new versions of GHC,
+ - but that one requires the entire string to be consumed.
+ -}
+readish :: Read a => String -> Maybe a
+readish s = case reads s of
+	((x,_):_) -> Just x
+	_ -> Nothing
+
+{- Like head but Nothing on empty list. -}
+headMaybe :: [a] -> Maybe a
+headMaybe = Data.Maybe.listToMaybe
+
+{- Like last but Nothing on empty list. -}
+lastMaybe :: [a] -> Maybe a
+lastMaybe [] = Nothing
+lastMaybe v = Just $ Prelude.last v
+
+{- All but the last element of a list.
+ - (Like init, but no error on an empty list.) -}
+beginning :: [a] -> [a]
+beginning [] = []
+beginning l = Prelude.init l
+
+{- Like last, but no error on an empty list. -}
+end :: [a] -> [a]
+end [] = []
+end l = [Prelude.last l]
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
new file mode 100644
index 0000000..4978d42
--- /dev/null
+++ b/Utility/QuickCheck.hs
@@ -0,0 +1,45 @@
+{- QuickCheck with additional instances
+ -
+ - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Utility.QuickCheck
+	( module X
+	, module Utility.QuickCheck
+	) where
+
+import Test.QuickCheck as X
+import Data.Time.Clock.POSIX
+import System.Posix.Types
+import Control.Applicative
+import Prelude
+
+{- Times before the epoch are excluded. -}
+instance Arbitrary POSIXTime where
+	arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral
+
+instance Arbitrary EpochTime where
+	arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral
+
+{- Pids are never negative, or 0. -}
+instance Arbitrary ProcessID where
+	arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)
+
+{- Inodes are never negative. -}
+instance Arbitrary FileID where
+	arbitrary = nonNegative arbitrarySizedIntegral
+
+{- File sizes are never negative. -}
+instance Arbitrary FileOffset where
+	arbitrary = nonNegative arbitrarySizedIntegral
+
+nonNegative :: (Num a, Ord a) => Gen a -> Gen a
+nonNegative g = g `suchThat` (>= 0)
+
+positive :: (Num a, Ord a) => Gen a -> Gen a
+positive g = g `suchThat` (> 0)