module Wumpus.Core.Utils
(
Opt(..)
, some
, applyIf
, rescale
, PSUnit(..)
, dtruncFmt
, truncateDouble
, roundup
, psTimeStamp
, H
, emptyH
, wrapH
, consH
, snocH
, appendH
, toListH
) where
import qualified Wumpus.Core.FormatCombinators as Fmt
import Data.Ratio
import Data.Time
data Opt a = None | Some !a
deriving (Eq,Show)
some :: a -> Opt a -> a
some dflt None = dflt
some _ (Some a) = a
applyIf :: Bool -> (a -> a) -> a -> a
applyIf cond fn a = if cond then fn a else a
rescale :: Fractional a => (a,a) -> (a,a) -> a -> a
rescale (amin,amax) (bmin,bmax) a =
bmin + apos * (brange / arange)
where
arange = amax amin
brange = bmax bmin
apos = a amin
class Num a => PSUnit a where
toDouble :: a -> Double
dtrunc :: a -> String
dtrunc = truncateDouble . toDouble
instance PSUnit Double where
toDouble = id
dtrunc = truncateDouble
instance PSUnit Float where
toDouble = realToFrac
instance PSUnit (Ratio Integer) where
toDouble = realToFrac
instance PSUnit (Ratio Int) where
toDouble = realToFrac
dtruncFmt :: PSUnit a => a -> Fmt.Doc
dtruncFmt = Fmt.text . dtrunc
truncateDouble :: Double -> String
truncateDouble d | abs d < 0.0001 = "0.0"
| d < 0.0 = '-' : show (abs tx)
| otherwise = show tx
where
tx :: Double
tx = (realToFrac (roundi (d*1000000.0))) / 1000000.0
roundi :: RealFrac a => a -> Integer
roundi = round
roundup :: Double -> String
roundup = show . ceilingi
ceilingi :: RealFrac a => a -> Integer
ceilingi = ceiling
psTimeStamp :: ZonedTime -> ShowS
psTimeStamp zt = localTimeS . showChar ' ' . localDayS
where
local_tim = zonedTimeToLocalTime zt
localTimeS = timeOfDay $ localTimeOfDay $ local_tim
localDayS = showString $ showGregorian $ localDay local_tim
timeOfDay :: TimeOfDay -> ShowS
timeOfDay t =
fn todHour . showChar ':' . fn todMin . showChar ':' . fn (floori . todSec)
where
fn f = pad2 (f t)
pad2 :: Int -> ShowS
pad2 i | i < 10 = ('0':) . shows i
| otherwise = shows i
floori :: RealFrac a => a -> Int
floori = floor
type H a = [a] -> [a]
emptyH :: H a
emptyH = id
wrapH :: a -> H a
wrapH a = consH a id
consH :: a -> H a -> H a
consH a f = (a:) . f
snocH :: H a -> a -> H a
snocH hl a = hl . (a:)
appendH :: H a -> H a -> H a
appendH f g = f . g
toListH :: H a -> [a]
toListH = ($ [])