module Data.Prefix.Units
(
Unit(..)
, RationalConvertible(..)
, siUnits
, siSupraunitary
, siKMGT
, binaryUnits
, unitMultiplier
, unitName
, unitSymbol
, fancySymbol
, FormatMode(..)
, recommendedUnit
, formatValue
, showValue
, ParseMode(..)
, parseSymbol
, parseValue
, unitRange
, ParseOptions(..)
, parseExactSymbol
, parseBinarySymbol
, parseKMGTSymbol
, parseGeneric
, showValueWith
) where
import Control.Monad.Instances ()
import Data.Char (toUpper)
import Data.List (intercalate)
default ()
data Unit = Yocto
| Zepto
| Atto
| Femto
| Pico
| Nano
| Micro
| Milli
| Centi
| Deci
| Deka
| Hecto
| Kilo
| Kibi
| Mega
| Mebi
| Giga
| Gibi
| Tera
| Tebi
| Peta
| Pebi
| Exa
| Exbi
| Zetta
| Yotta
deriving (Show, Eq, Enum, Bounded, Ord)
siUnits :: [Unit]
siUnits
= [Yocto, Zepto, Atto, Femto, Pico, Nano, Micro, Milli, Centi,
Deci, Deka, Hecto, Kilo, Mega, Giga, Tera, Peta, Exa, Zetta, Yotta]
binaryUnits :: [Unit]
binaryUnits = [Kibi, Mebi, Gibi, Tebi, Pebi, Exbi]
siSupraunitary :: [Unit]
siSupraunitary = filter (>= Deka) siUnits
siKMGT :: [Unit]
siKMGT = filter (>= Kilo) siUnits
unitMultiplier :: Unit -> Rational
unitMultiplier Yocto = 10.0 ^^ (24 :: Int)
unitMultiplier Zepto = 10.0 ^^ (21 :: Int)
unitMultiplier Atto = 10.0 ^^ (18 :: Int)
unitMultiplier Femto = 10.0 ^^ (15 :: Int)
unitMultiplier Pico = 10.0 ^^ (12 :: Int)
unitMultiplier Nano = 10.0 ^^ ( 9 :: Int)
unitMultiplier Micro = 10.0 ^^ ( 6 :: Int)
unitMultiplier Milli = 10.0 ^^ ( 3 :: Int)
unitMultiplier Centi = 10.0 ^^ ( 2 :: Int)
unitMultiplier Deci = 10.0 ^^ ( 1 :: Int)
unitMultiplier Deka = 10.0 ^^ ( 1 :: Int)
unitMultiplier Hecto = 10.0 ^^ ( 2 :: Int)
unitMultiplier Kilo = 10.0 ^^ ( 3 :: Int)
unitMultiplier Kibi = 2.0 ^^ ( 10 :: Int)
unitMultiplier Mega = 10.0 ^^ ( 6 :: Int)
unitMultiplier Mebi = 2.0 ^^ ( 20 :: Int)
unitMultiplier Giga = 10.0 ^^ ( 9 :: Int)
unitMultiplier Gibi = 2.0 ^^ ( 30 :: Int)
unitMultiplier Tera = 10.0 ^^ ( 12 :: Int)
unitMultiplier Tebi = 2.0 ^^ ( 40 :: Int)
unitMultiplier Peta = 10.0 ^^ ( 15 :: Int)
unitMultiplier Pebi = 2.0 ^^ ( 50 :: Int)
unitMultiplier Exa = 10.0 ^^ ( 18 :: Int)
unitMultiplier Exbi = 2.0 ^^ ( 60 :: Int)
unitMultiplier Zetta = 10.0 ^^ ( 21 :: Int)
unitMultiplier Yotta = 10.0 ^^ ( 24 :: Int)
unitName :: Unit -> String
unitName Yocto = "yocto"
unitName Zepto = "zepto"
unitName Atto = "atto"
unitName Femto = "femto"
unitName Pico = "pico"
unitName Nano = "nano"
unitName Micro = "micro"
unitName Milli = "milli"
unitName Centi = "centi"
unitName Deci = "deci"
unitName Deka = "deka"
unitName Hecto = "hecto"
unitName Kilo = "kilo"
unitName Kibi = "kibi"
unitName Mega = "mega"
unitName Mebi = "mebi"
unitName Giga = "giga"
unitName Gibi = "gibi"
unitName Tera = "tera"
unitName Tebi = "tebi"
unitName Peta = "peta"
unitName Pebi = "pebi"
unitName Exa = "exa"
unitName Exbi = "exbi"
unitName Zetta = "zetta"
unitName Yotta = "yotta"
unitSymbol :: Unit -> String
unitSymbol Yocto = "y"
unitSymbol Zepto = "z"
unitSymbol Atto = "a"
unitSymbol Femto = "f"
unitSymbol Pico = "p"
unitSymbol Nano = "n"
unitSymbol Micro = "u"
unitSymbol Milli = "m"
unitSymbol Centi = "c"
unitSymbol Deci = "d"
unitSymbol Deka = "da"
unitSymbol Hecto = "h"
unitSymbol Kilo = "k"
unitSymbol Kibi = "Ki"
unitSymbol Mega = "M"
unitSymbol Mebi = "Mi"
unitSymbol Giga = "G"
unitSymbol Gibi = "Gi"
unitSymbol Tera = "T"
unitSymbol Tebi = "Ti"
unitSymbol Peta = "P"
unitSymbol Pebi = "Pi"
unitSymbol Exa = "E"
unitSymbol Exbi = "Ei"
unitSymbol Zetta = "Z"
unitSymbol Yotta = "Y"
fancySymbol :: Unit -> String
fancySymbol Micro = "\xb5"
fancySymbol u = unitSymbol u
class (Real a) => RationalConvertible a where
convFromRational :: Rational -> a
instance RationalConvertible Int where
convFromRational = round
instance RationalConvertible Integer where
convFromRational = round
instance RationalConvertible Float where
convFromRational = fromRational
instance RationalConvertible Double where
convFromRational = fromRational
instance RationalConvertible Rational where
convFromRational = id
scaleToUnit :: (RationalConvertible a) => a -> Unit -> a
scaleToUnit val = convFromRational . (rational_val /) . unitMultiplier
where rational_val = toRational val
scaleFromUnit :: (RationalConvertible a) => a -> Unit -> a
scaleFromUnit val = convFromRational . (rational_val *) . unitMultiplier
where rational_val = toRational val
data FormatMode
= FormatSiAll
| FormatSiSupraunitary
| FormatSiKMGT
| FormatBinary
deriving (Show, Enum, Bounded)
type FormatOption = Either FormatMode Unit
unitRange :: FormatMode -> [Unit]
unitRange FormatSiAll = siUnits
unitRange FormatSiSupraunitary = siSupraunitary
unitRange FormatSiKMGT = siKMGT
unitRange FormatBinary = binaryUnits
recommendedUnit :: (Real a) => FormatMode -> a -> Maybe Unit
recommendedUnit fmt val =
let range = unitRange fmt
ratv = Prelude.toRational val
in foldr (\u a -> if ratv / unitMultiplier u >= 1 then Just u else a)
Nothing $ reverse range
formatValue :: (RationalConvertible a) =>
FormatOption
-> a
-> (a, Maybe Unit)
formatValue fmt val =
let unit = either (`recommendedUnit` val) Just fmt
scaled = maybe val (scaleToUnit val) unit
in (scaled, unit)
showValueWith :: (RationalConvertible a, Show a) =>
(Unit -> String)
-> FormatOption
-> a
-> String
showValueWith symbfn fmt val =
let (scaled, unit) = formatValue fmt val
in show scaled ++ maybe "" symbfn unit
showValue :: (RationalConvertible a, Show a) =>
FormatOption
-> a
-> String
showValue = showValueWith unitSymbol
unknownUnit :: String -> Either String Unit
unknownUnit unit = Left $ "Unrecognised unit '" ++ unit ++ "'"
parseExactSymbol :: String -> Either String Unit
parseExactSymbol "y" = Right Yocto
parseExactSymbol "z" = Right Zepto
parseExactSymbol "a" = Right Atto
parseExactSymbol "f" = Right Femto
parseExactSymbol "p" = Right Pico
parseExactSymbol "n" = Right Nano
parseExactSymbol "u" = Right Micro
parseExactSymbol "m" = Right Milli
parseExactSymbol "c" = Right Centi
parseExactSymbol "d" = Right Deci
parseExactSymbol "da" = Right Deka
parseExactSymbol "h" = Right Hecto
parseExactSymbol "k" = Right Kilo
parseExactSymbol "Ki" = Right Kibi
parseExactSymbol "M" = Right Mega
parseExactSymbol "Mi" = Right Mebi
parseExactSymbol "G" = Right Giga
parseExactSymbol "Gi" = Right Gibi
parseExactSymbol "T" = Right Tera
parseExactSymbol "Ti" = Right Tebi
parseExactSymbol "P" = Right Peta
parseExactSymbol "Pi" = Right Pebi
parseExactSymbol "E" = Right Exa
parseExactSymbol "Ei" = Right Exbi
parseExactSymbol "Z" = Right Zetta
parseExactSymbol "Y" = Right Yotta
parseExactSymbol unit = unknownUnit unit
helperParseBinary :: String -> Either String Unit
helperParseBinary "K" = Right Kibi
helperParseBinary "KI" = Right Kibi
helperParseBinary "M" = Right Mebi
helperParseBinary "MI" = Right Mebi
helperParseBinary "G" = Right Gibi
helperParseBinary "GI" = Right Gibi
helperParseBinary "T" = Right Tebi
helperParseBinary "TI" = Right Tebi
helperParseBinary "P" = Right Pebi
helperParseBinary "PI" = Right Pebi
helperParseBinary "E" = Right Exbi
helperParseBinary "EI" = Right Exbi
helperParseBinary symbol = unknownUnit symbol
parseBinarySymbol :: String -> Either String Unit
parseBinarySymbol = helperParseBinary . upperSym
helperParseKMGT :: String -> Either String Unit
helperParseKMGT "K" = Right Kilo
helperParseKMGT "KI" = Right Kibi
helperParseKMGT "M" = Right Mega
helperParseKMGT "MI" = Right Mebi
helperParseKMGT "G" = Right Giga
helperParseKMGT "GI" = Right Gibi
helperParseKMGT "T" = Right Tera
helperParseKMGT "TI" = Right Tebi
helperParseKMGT "P" = Right Peta
helperParseKMGT "PI" = Right Pebi
helperParseKMGT "E" = Right Exa
helperParseKMGT "EI" = Right Exbi
helperParseKMGT "Z" = Right Zetta
helperParseKMGT "Y" = Right Yotta
helperParseKMGT symbol = unknownUnit symbol
parseKMGTSymbol :: String -> Either String Unit
parseKMGTSymbol = helperParseKMGT . upperSym
data ParseMode
= ParseExact
| ParseKMGT
| ParseBinary
deriving (Show, Enum, Bounded)
data ParseOptions
= UnitRequired
| UnitDefault Unit
| UnitOptional
deriving (Show)
parseSymbol :: ParseMode -> String -> Either String Unit
parseSymbol ParseExact = parseExactSymbol
parseSymbol ParseKMGT = parseKMGTSymbol
parseSymbol ParseBinary = parseBinarySymbol
parseValue :: (Read a, RationalConvertible a) =>
ParseMode
-> String
-> Either String a
parseValue = parseGeneric UnitOptional []
validUnit :: [Unit] -> Unit -> Either String Unit
validUnit [] unit = Right unit
validUnit ulist unit =
if unit `notElem` ulist
then Left $ "Unit '" ++ show unit ++ "' not part of the accepted" ++
" unit list (" ++ intercalate ", " (map show ulist) ++ ")"
else Right unit
processUnit :: ParseOptions
-> ParseMode
-> [Unit]
-> String
-> Maybe (Either String Unit)
processUnit popts pmode valid_units unit_suffix =
if null unit_suffix
then case popts of
UnitRequired -> Just $ Left "An unit is required but the\
\ input string lacks one"
UnitDefault def_unit -> Just $ Right def_unit
UnitOptional -> Nothing
else Just $
either Left (validUnit valid_units) (parseSymbol pmode unit_suffix)
parseGeneric :: (Read a, RationalConvertible a) =>
ParseOptions
-> [Unit]
-> ParseMode
-> String
-> Either String a
parseGeneric popts valid_units pmode str =
case reads str of
[(v, suffix)] ->
let unit_suffix = dropWhile (== ' ') suffix
unit = processUnit popts pmode valid_units unit_suffix
in maybe (Right v) (fmap (scaleFromUnit v)) unit
_ -> Left $ "Can't parse string '" ++ str ++ "'"
upperSym :: String -> String
upperSym = map toUpper