CODEWITHSUNDEEP
haskell
Dragno
Dragno

Reputation: 3134

Generic implementation of function that convert between Kilo Mega Giga in Haskell

Suppose that I have the following code:

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeOperators #-}
module Lib
( someFunc
) where
import GHC.Generics
data DataAmount = KB Double | MB Double | GB Double deriving Generic
data Speed = KBs Double | MBs Double | GBs Double deriving Generic

convertToKB x = case x of
            (KB _ )-> x
            (MB k )-> KB (1000.0*k)            
            (GB k )-> KB (1000000.0*k)
convertToKBs x = case x of
             (KBs _) -> x
             (MBs k) -> KBs (1000.0*k)
             (GBs k) -> KBs (1000000.0*k)
class ConvertToK a where
 convertToK :: a->a

class ConvertToK' f where
 convertToK' :: f p -> ?

instance (ConvertToK' f,ConvertToK' g) => ConvertToK' (f :+: g) where
 convertToK' (L1 x) = ?
 convertToK' (R1 x) = ?

timeDiv (KB x) (KBs z) | z>0 = x/z
someFunc :: IO ()
someFunc = do
         putStrLn "Gime the amount of data:"
         dat <- readLn
         putStrLn "Gime 1 for KB 2 for MB 3 for GB:"
         unit <- readLn 
         let dataAmount = case unit of
                            1 -> KB dat
                            2 -> MB dat
                            3 -> GB dat
                            _ -> KB dat
         putStrLn "Gime speed of data:"
         speed <- readLn
         putStrLn "Gime 1 for KB/s 2 for MB/s 3 for GB/s:"
         speedunit <- readLn 
         let speedAmount = case speedunit of
                                1 -> KBs speed
                                2 -> MBs speed
                                3 -> GBs speed
                                _ -> KBs speed
         let speedAmountKBs = convertToKBs speedAmount
         let dataAmountKB = convertToKB dataAmount
         let result = timeDiv dataAmountKB speedAmountKBs
         putStrLn $ "You need " ++ show result ++ " seconds"

Notice that there are 3 question marks to denote that I don't know what to write there. I just want to create one convert function to convert between Kilo,Mega and Giga provided that everything will be converted to Kilo. For example if I have 1 GB/sec this will become 1 000 000 KB per second. I have created two such functions convertToKB for KiloBytes and convertToKBs for Kilobytes per second. The logic is the same for both, if something is Kilo do nothing, if something is Mega multiply by 1000 if is Giga multiply by 1000000. I tried to do this with Generics but I can't because I need to take the name of the data constructor if the name begins with "K" then do nothing if with "M" ... etc . All the examples and in the paper that introduced Generics and in the hackage documentation have to do with an encode function that converts a type to Bit or Bool. In this example the whole data structure is traversed and the encode function is applied everywhere without distinction. I found also in generics-deriving package a ConNames function but there is no an example of how to use it. Please help.

Upvotes: 0

Views: 223

Answers (4)

Dragno
Dragno

Reputation: 3134

This is not a full answer but food for thought. I was inspired from @K.A.Buhr to use a common type for denoting the Kilo, Mega etc and then I used SYB for creating a general convert. But I don't think it's totally type-safe here's my code:

{-# LANGUAGE DeriveDataTypeable #-}
module Lib
( someFunc
) where
import Data.Generics.SYB
import Data.Generics.Uniplate.Data
import Data.Typeable
import Data.Data
someFunc :: IO ()
someFunc = do
        let speed = Sp (M 11.0)
        let (Sp c) = convert speed
        let k = case c of
                 K x -> x
                 M x -> x
                 G x -> x
        print k
 data KMBG = K Double|M Double | G Double deriving(Data,Typeable)

 data Speed = Sp KMBG deriving(Data,Typeable)
 data Size = Ss Double deriving (Data,Typeable)


 baseConvert (K x) = K x
 baseConvert (M x) = K (1000*x)
 baseConvert (G x) = K (1000000*x)


 convert :: (Data a)=>a->a
 convert = everywhere (mkT baseConvert)

Can we restrict convert to be used only on types that use KMBG as their scaling prefix?

Upvotes: 0

K. A. Buhr
K. A. Buhr

Reputation: 50884

Okay, here's a second "answer" that tries to offer what I think are some better approaches to this problem. Solution #2 is probably worth taking seriously. Solutions #3-#5 show increasingly complex (and increasingly type-safe) ways of representing prefixes in your data types.

Anyway, here's my understanding of your requirements.

  1. You want to represent a variety of physical measurements (e.g., amount of data, and transmission speed) in a variety of base units (e.g., bytes and bytes per second), with a variety of "metric prefixes" (kilo, mega, giga).

  2. For calculations (e.g., calculating transmission time), you want to be able to handle any mixture of metric prefixes on the input arguments in a simple, uniform way. For example, you don't want to have to write:

    timeDiv (KB x) (KBs z) | z > 0 = x / z
timeDiv (MB x) (KBs z) | z > 0 = x*1000 / z
...all 9 combinations...
timeDiv (GB x) (GBs z) | z > 0 = x / z

  3. You also don't want to have to write a convertToKXXX function separately for every possible unit.

In addition, though it wasn't explicitly part of your requirements, I would add that:

  1. You want to make it type safe in the base units, meaning that timeDiv shouldn't be able to divide two DataAmounts or get the division backwards (e.g., dividing Speed by `DataAmount).'
  2. You want to make it type safe in the prefixes, meaning that you shoudn't be able to get a wrong answer or crash your program by forgetting to convert a GB before passing it to timeDiv.

Note that your current approach fails on point 3 (which is why you asked the question in the first place), but it also fails on point 5. For example, nothing prevents you from writing:

badMain = print $ timeDiv (GB 1000) (MBs 100)

which compiles fine and then gives a non-exhaustive pattern error at runtime because the two arguments haven't been converted to kilos.

So, what are some better solutions?

Solution 1: Uniform Representation in Base Units

This is such an obvious solution it's easy to overlook. It's possible that you don't actually need to represent the metric prefixes as part of the data type, if you only need them at the input and output "boundaries" of your core logic. That is, consider if you might represent values of different physical quantities in a standard unit with only a single real constructor per type:

newtype DataAmount = B Double  -- in bytes
newtype Speed = Bs Double      -- in bytes per second

This makes it easy to define a type-safe timeDiv (well, relatively type-safe, as we reject negative speeds still). In fact, we ought to introduce a type for time as well:

newtype Time = S Double deriving (Show)    -- in seconds

timeDiv :: DataAmount -> Speed -> Time
timeDiv (B x) (Bs z) | z > 0     = S (x / z)
                     | otherwise = error "timeDiv: non-positive Speed"

For scaling, let's introduce a type for prefixes (with I for the "identity" indicating no prefix):

data Prefix = I | K | M | G deriving (Show, Read)

and a type class for handling input and output from values in prefixed units. The type class will only need to convert to and from the Double value presumed to be in non-prefixed units:

class Scalable a where
  toScalable :: Double -> a
  fromScalable :: a -> Double

and some tedious boilerplate for the instances:

instance Scalable DataAmount where
  toScalable = B
  fromScalable (B x) = x
instance Scalable Speed where
  toScalable = Bs
  fromScalable (Bs x) = x
instance Scalable Time where
  toScalable = S
  fromScalable (S x) = x

Then, we can define:

fromPrefix :: (Scalable a) => Prefix -> Double -> a
fromPrefix I x = toScalable x
fromPrefix K x = toScalable (1e3 * x)
fromPrefix M x = toScalable (1e6 * x)
fromPrefix G x = toScalable (1e9 * x)

toPrefix :: (Scalable a) => Prefix -> a -> Double
toPrefix I x = fromScalable x
toPrefix K x = fromScalable x / 1e3
toPrefix M x = fromScalable x / 1e6
toPrefix G x = fromScalable x / 1e9

allowing us to write things like:

-- what is time in kiloseconds to transfer 100G over 10MB/s?
doStuff = print $ toPrefix K $ timeDiv (fromPrefix G 100) (fromPrefix M 10)

and we rewrite your main program as follows (with modifications to take advantage of the Read instance for Prefix:

someFunc :: IO ()
someFunc = do
         putStrLn "Gime the amount of data:"
         dat <- readLn
         putStrLn "Gime K for KB, M for MB, G for GB:"
         unit <- readLn
         let dataAmount = fromPrefix unit dat
         putStrLn "Gime speed of data:"
         speed <- readLn
         putStrLn "Gime K for KB/s M for MB/s G for GB/s:"
         speedunit <- readLn
         let speedAmount = fromPrefix speedunit speed
         let S result = timeDiv dataAmount speedAmount
         putStrLn $ "You need " ++ show result ++ " seconds"

Solution 2: Forget the type class

In fact, even the above solution may be over-engineered. You can do it all without a type class. Try defining the types and prefixes and timeDiv as before:

newtype DataAmount = B Double deriving (Show)  -- in bytes
newtype Speed = Bs Double deriving (Show)      -- in bytes per second
newtype Time = S Double deriving (Show)        -- in seconds
data Prefix = I | K | M | G deriving (Show, Read)
timeDiv :: DataAmount -> Speed -> Time
timeDiv (B x) (Bs z) | z > 0     = S (x / z)
                     | otherwise = error "timeDiv: non-positive Speed"

but use:

fromPrefix :: Double -> Prefix -> (Double -> a) -> a
fromPrefix x p u = u (scale p x)
  where scale I = id
        scale K = (1e3*)
        scale M = (1e6*)
        scale G = (1e9*)

This allows:

neatFunc :: IO ()
-- divide 100 GB by 100 MB/s
neatFunc = print $ timeDiv (fromPrefix 100 G B) (fromPrefix 10 M Bs)

and you can rewrite your someFunc as:

someFunc :: IO ()
someFunc = do
         putStrLn "Gime the amount of data:"
         dat <- readLn
         putStrLn "Gime K for KB, M for MB, G for GB:"
         unit <- readLn
         let dataAmount = fromPrefix dat unit B
         putStrLn "Gime speed of data:"
         speed <- readLn
         putStrLn "Gime K for KB/s M for MB/s G for GB/s:"
         speedunit <- readLn
         let speedAmount = fromPrefix speed speedunit Bs
         let S result = timeDiv dataAmount speedAmount
         putStrLn $ "You need " ++ show result ++ " seconds"

Writing toPrefix is harder without a type class (e.g., that provides fromScalable), but maybe it's enough to have:

unPrefix :: Prefix -> Double -> Double
unPrefix I x = x
unPrefix K x = x/1e3
unPrefix M x = x/1e6
unPrefix G x = x/1e9

so you can calculate kiloseconds by manually pattern matching on the S constructor with:

example1 = print $ ks  -- answer in kiloseconds
  where ks = let S s = timeDiv (fromPrefix 100 G B) (fromPrefix 10 M Bs)
             in  unPrefix K s

Solution 3: Shared Representation for Prefixes

If you decide you really do want the prefixes as part of the data representation, then the simplest way of avoiding a lot of unnecessary boilerplate is to separate the types representing the physical quantities from the type representing the prefixed values. That is, let's define a unitless but prefixed Value type that can be shared across different physical quanities, like so:

data Value = Value Prefix Double deriving (Show)
data Prefix = I | K | M | G deriving (Show, Read)

Then, our physical quantities are wrappers around Value instead of Double. We can name the constructors after the base units (B for bytes, etc.):

newtype DataAmount = B Value
newtype Speed = Bs Value
newtype Time = S Value deriving (Show)

Define convertToK (or to keep things simple, convertToI to convert to base units) for Value types, instead of DataAmount and Speed:

convertToI :: Value -> Value
convertToI v@(Value I _) = v
convertToI   (Value K x) = Value I (x*1e3)
convertToI   (Value M x) = Value I (x*1e6)
convertToI   (Value G x) = Value I (x*1e9)

Now, we can define a version of timeDivI that can operate on prefix-less units only:

timeDivI :: DataAmount -> Speed -> Time
timeDivI (B (Value I x)) (Bs (Value I z))
  | z > 0      = S (Value I (x/z))
  | otherwise = error "timeDiv: non-positive Speed"

as well as a more general version that can handle any prefixes:

timeDiv :: DataAmount -> Speed -> Time
timeDiv (B bytes) (Bs bps) = timeDivI (B (convertToI bytes)) (Bs (convertToI bps))

and we can rewrite your someFunc as:

someFunc :: IO ()
someFunc = do
  putStrLn "Gime the amount of data:"
  dat <- readLn
  putStrLn "Gime K for KB, M for MB, G for GB:"
  unit <- readLn
  let dataAmount = B (Value unit dat)
  putStrLn "Gime speed of data:"
  speed <- readLn
  putStrLn "Gime K for KB/s M for MB/s G for GB/s:"
  speedunit <- readLn
  let speedAmount = Bs (Value speedunit speed)
  let s = timeDiv dataAmount speedAmount
  putStrLn $ "You need time " ++ show s

This is pretty good. It meets requirements 1-4, and it comes quite close on requirement 5. timeDivI isn't type safe (same problem as badMain above), but we can hide it in a where clause under the type safe timeDiv function which handles all possible inputs. Basically, this provides good type safety for users of our functions but doesn't provide much type safety for developing them.

Solution 4: Representing Prefixes with Types using DataKinds

We can increase type safety by raising the prefixes to the type level using DataKinds. This comes at the expense of a significant increase in complexity.

With the help of some extensions:

{-# LANGUAGE DataKinds, KindSignatures #-}

we can define a family of prefixed Value types:

newtype Value (p :: Prefix) = Value Double

indexed by type "tags" for prefixes:

data Prefix = I | K | M | G deriving (Show, Read)

This allows us to define our previous set of physical quantities:

newtype DataAmount p = B (Value p)
newtype Speed p = Bs (Value p)
newtype Time p = S (Value p)

Now, the type DataAmount G is an amount of data in gigabytes, and Time I is a time value in (prefixless) seconds.

The equivalent of your original timeDiv function is, more or less:

timeDiv :: DataAmount K -> Speed K -> Time I
timeDiv (B (Value kb)) (Bs (Value kbs)) = S (Value (kb/kbs))

This is type safe. You can't accidentally call it on gigabytes of data amount or kilobytes per second of speed, and you can't misuse the return value as kiloseconds -- all that will fail at compile time. However, while it's easy to define individual conversion functions like:

convertMToK :: Value M -> Value K
convertMToK (Value m) = Value (1e3*m)

trying to define a general convertToK that handles all prefixes:

convertToK :: Value p -> Value K

ends up being difficult (i.e., impossible).

Instead, we need to define Value in such a way that we can extract prefix information at runtime, but in a type-safe manner. This calls for the use of GADTs, so let's try again with more extensions:

{-# LANGUAGE DataKinds, GADTs, KindSignatures, RankNTypes, StandaloneDeriving #-}

and define Value as a GADT with a constructor for each prefix:

data Value (p :: Prefix) where
  IValue :: Double -> Value I
  KValue :: Double -> Value K
  MValue :: Double -> Value M
  GValue :: Double -> Value G
data Prefix = I | K | M | G deriving (Show, Read)
deriving instance Show (Value p)

Our physical quantities are defined as before:

newtype DataAmount p = B (Value p)
newtype Speed p = Bs (Value p)
newtype Time p = S (Value p) deriving (Show)

but this GADT allows us to define a convertToI function like so:

convertToI :: Value p -> Value I
convertToI i@(IValue _) = i   -- no conversion needed
convertToI   (KValue x) = IValue (1e3*x)
convertToI   (MValue x) = IValue (1e6*x)
convertToI   (GValue x) = IValue (1e9*x)

and now we can define a type-safe timeDivI that works for any base (unprefixed) division of DataAmount by Speed:

timeDivI :: DataAmount I -> Speed I -> Time I
timeDivI (B (IValue bytes)) (Bs (IValue bps))
  | bps > 0   = S (IValue (bytes / bps))
  | otherwise = error "TODO: replace with enterprisey exception"

and a general (and type-safe) timeDiv that can handle any input prefixes with convertToI and any output prefix with convertFromI (and see below for the meaning of KnownPrefix):

timeDiv :: (KnownPrefix p3) => DataAmount p1 -> Speed p2 -> Time p3
timeDiv (B bytes) (Bs bps)
  = let S v = timeDivI (B (convertToI bytes)) (Bs (convertToI bps))
    in  S (convertFromI v)

It turns out that convertFromI is tough to write. It requires the use of a singleton. (To see why, try writing a function convertFromI :: Value I -> Value p and see how far you can get...)

Anyway, the singleton is defined as a GADT:

data SPrefix p where
  SI :: SPrefix I
  SK :: SPrefix K
  SM :: SPrefix M
  SG :: SPrefix G
deriving instance Show (SPrefix p)

and we can write a convertFromI' version that accepts an explicit singleton to perform the correct conversion:

convertFromI' :: SPrefix p -> Value I -> Value p
convertFromI' SI v = v
convertFromI' SK (IValue base) = KValue (base/1e3)
convertFromI' SM (IValue base) = MValue (base/1e6)
convertFromI' SG (IValue base) = GValue (base/1e9)

Then, we can avoid the need to actually supply explicit singletons by using a standard type class trick:

class    KnownPrefix p where singPrefix :: SPrefix p
instance KnownPrefix I where singPrefix = SI
instance KnownPrefix K where singPrefix = SK
instance KnownPrefix M where singPrefix = SM
instance KnownPrefix G where singPrefix = SG

to write:

convertFromI :: (KnownPrefix p) => Value I -> Value p
convertFromI = convertFromI' singPrefix

This infrastructure is awesome (some irony intended). Observe:

awesomeFunc = do
  let dat   = B (GValue 1000) :: DataAmount G  -- 1000 gigabytes
      speed = Bs (MValue 100) :: Speed M       -- 100 megabytes
      -- timeDiv takes args w/ arbitrary prefixes...
      time1 = timeDiv dat speed :: Time I  -- seconds
      -- ...and can return values w/ arbitrary prefixes.
      time2 = timeDiv dat speed :: Time K  -- kiloseconds
      -- ...
  print (time1, time2)

This prints:

> awesomeFunc
(S (IValue 10000.0),S (KValue 10.0))

It's also extraordinarily typesafe. Just try to break it...

Seriously, though, while this looks complicated, this is probably the best type safe way of dealing with representations of unit prefixes in production code. The type safety and reusable conversion functions are big benefits.

Unfortunately, this works best when the prefixes are known at compile time. To rewrite your someFunc, we need a way of representing a Value whose prefix isn't known until runtime. The standard method is an existential type that contains both the prefix (as a singeton) and the value:

data SomeValue where
  SomeValue :: SPrefix p -> Value p -> SomeValue
deriving instance Show SomeValue

To work with SomeValue terms, we'll want a way to create a value of this type from a Double and Prefix:

someValue :: Double -> Prefix -> SomeValue
someValue x I = SomeValue SI (IValue x)
someValue x K = SomeValue SK (KValue x)
someValue x M = SomeValue SM (MValue x)
someValue x G = SomeValue SG (GValue x)

and we'll find it helpful to define a function that makes it convenient to use a SomeValue where we need a Value:

withSomeValue :: SomeValue -> (forall p . Value p -> a) -> a
withSomeValue sv f = case sv of
  SomeValue SI v -> f v
  SomeValue SK v -> f v
  SomeValue SM v -> f v
  SomeValue SG v -> f v

And now we can write:

someFunc :: IO ()
someFunc = do
  putStrLn "Gime the amount of data:"
  dat <- readLn
  putStrLn "Gime K for KB, M for MB, G for GB:"
  unit <- readLn
  let dataAmount = someValue dat unit :: SomeValue
  putStrLn "Gime speed of data:"
  speed <- readLn
  putStrLn "Gime K for KB/s M for MB/s G for GB/s:"
  speedunit <- readLn
  let speedAmount = someValue speed speedunit :: SomeValue
  withSomeValue dataAmount $ \d -> withSomeValue speedAmount $ \s -> do
    let S (KValue ks) = timeDiv (B d) (Bs s) :: Time K
    putStrLn $ "You need " ++ show ks ++ " kiloseconds"

One drawback of this solution is that we can't parse dataAmount directly into a DataAmount type because there's no SomeDataAmount existential equivalent to SomeValue. As a result, there's a type safety "gap" between when we define dataAmount as an arbitrary SomeValue and when we wrap it with the B constructor just before passing it to timeDiv. In other words, we aren't doing a good job with requirement #4. One solution would be to define SomeDataAmount and SomeSpeed and so on, but that would be very tedious. Another solution is to lift more information to "tags" at the type level...

Solution 5: Lifting Quantities and Units to the type level

If everything above seems too simple then the truly industrial-strength, "enterprise" solution will be to represent physical quanitites, their units, and their prefixes at type level in a single universal Value type.

With a bunch of language extensions:

{-# LANGUAGE DataKinds, GADTs, KindSignatures, PolyKinds, RankNTypes, StandaloneDeriving, TypeFamilies #-}

we'll define a family of Value types that's tagged by physical quantity and prefix. The Value will be a GADT to allow runtime inspection of prefixes:

data Value (q :: Quantity) (p :: Prefix) where
  IValue :: Double -> Value q I
  KValue :: Double -> Value q K
  MValue :: Double -> Value q M
  GValue :: Double -> Value q G
data Quantity = DataAmount | Speed | Time | FileSize
data Prefix = I | K | M | G deriving (Show, Read)
deriving instance Show (Value q p)

Where are the units? Well, because the physical quantity determines its unit, we'll use a type family to map Quantity to Unit. This does allow different physical quantity types (e.g., DataAmount and FileSize) to share units:

data Unit = B | Bs | S deriving (Show)
type family QuantityUnit q where
  QuantityUnit DataAmount = B
  QuantityUnit FileSize = B
  QuantityUnit Speed = Bs
  QuantityUnit Time = S

As before, the Value GADT allows us to define a convertToI to convert to base units:

convertToI :: Value q p -> Value q I
convertToI i@(IValue _) = i   -- no conversion needed
convertToI   (KValue x) = IValue (1e3*x)
convertToI   (MValue x) = IValue (1e6*x)
convertToI   (GValue x) = IValue (1e9*x)

and now we can define a type-safe timeDivI that works for any base (unprefixed) division of bytes by seconds, regardless of which physical quanitites are involved (as long as their units are correct):

timeDivI :: (QuantityUnit bytes ~ B, QuantityUnit bps ~ Bs, QuantityUnit secs ~ S)
         => Value bytes I -> Value bps I -> Value secs I
timeDivI (IValue bytes) (IValue bps)
  | bps > 0   = IValue (bytes / bps)
  | otherwise = error "TODO: replace with enterprisey exception"

In addition, here's a general, type-safe timeDiv that can handle any input and output prefixes:

timeDiv :: (QuantityUnit bytes ~ B, QuantityUnit bps ~ Bs, QuantityUnit secs ~ S, KnownPrefix p3)
         => Value bytes p1 -> Value bps p2 -> Value secs p3
timeDiv bytes bps = convertFromI $ timeDivI (convertToI bytes) (convertToI bps)

As before, convertFromI requires a singleton approach:

data SPrefix p where
  SI :: SPrefix I
  SK :: SPrefix K
  SM :: SPrefix M
  SG :: SPrefix G
deriving instance Show (SPrefix p)
convertFromI' :: SPrefix p -> Value q I -> Value q p
convertFromI' SI v = v
convertFromI' SK (IValue base) = KValue (base/1000)
convertFromI' SM (IValue base) = MValue (base/1000)
convertFromI' SG (IValue base) = GValue (base/1000)

class    KnownPrefix p where singPrefix :: SPrefix p
instance KnownPrefix I where singPrefix = SI
instance KnownPrefix K where singPrefix = SK
instance KnownPrefix M where singPrefix = SM
instance KnownPrefix G where singPrefix = SG

convertFromI :: (KnownPrefix p) => Value q I -> Value q p
convertFromI = convertFromI' singPrefix

This infrastructure is even more awesome than before:

awesomerFunc = do
  let dat   = GValue 1000 :: Value DataAmount G  -- 1000 gigabytes of data
      fs    = MValue 15   :: Value FileSize M    -- 15 megabytes in file
      speed = MValue 100  :: Value Speed M       -- 100 MB/s
      -- timeDiv works with DataAmount...
      time1 = timeDiv dat speed :: Value Time I  -- seconds
      -- ...and FileSize, with args having arbitrary prefixes...
      time2 = timeDiv fs speed  :: Value Time K  -- kiloseconds
      -- ...and can return values w/ arbitrary prefixes.
  print (time1, time2)

This prints:

> awesomerFunc
(IValue 10000.0,KValue 1.5e-4)
>

Again, to rewrite your someFunc, we need an existential version:

data SomeValue q where
  SomeValue :: SPrefix p -> Value q p -> SomeValue q
deriving instance Show (SomeValue q)

someValue :: Double -> Prefix -> SomeValue q
someValue x I = SomeValue SI (IValue x)
someValue x K = SomeValue SK (KValue x)
someValue x M = SomeValue SM (MValue x)
someValue x G = SomeValue SG (GValue x)

withSomeValue :: SomeValue q -> (forall p . Value q p -> a) -> a
withSomeValue sv f = case sv of
  SomeValue SI v -> f v
  SomeValue SK v -> f v
  SomeValue SM v -> f v
  SomeValue SG v -> f v

And now we can write:

someFunc :: IO ()
someFunc = do
  putStrLn "Gime the amount of data:"
  dat <- readLn
  putStrLn "Gime K for KB, M for MB, G for GB:"
  unit <- readLn
  let dataAmount = someValue dat unit :: SomeValue DataAmount
  putStrLn "Gime speed of data:"
  speed <- readLn
  putStrLn "Gime K for KB/s M for MB/s G for GB/s:"
  speedunit <- readLn
  let speedAmount = someValue speed speedunit :: SomeValue Speed
  withSomeValue dataAmount $ \d -> withSomeValue speedAmount $ \s -> do
    let KValue ks = timeDiv d s :: Value Time K
    putStrLn $ "You need " ++ show ks ++ " kiloseconds"

Program Listings

Here are the program listings for the simplest (#2) and most complex (#5) solutions:

-- Solution 2: skipping the typeclass

newtype DataAmount = B Double deriving (Show)  -- in bytes
newtype Speed = Bs Double deriving (Show)      -- in bytes per second
newtype Time = S Double deriving (Show)        -- in seconds

data Prefix = I | K | M | G deriving (Show, Read)

timeDiv :: DataAmount -> Speed -> Time
timeDiv (B x) (Bs z) | z > 0     = S (x / z)
                     | otherwise = error "timeDiv: non-positive Speed"

fromPrefix :: Double -> Prefix -> (Double -> a) -> a
fromPrefix x p u = u (scale p x)
  where scale I = id
        scale K = (1e3*)
        scale M = (1e6*)
        scale G = (1e9*)

neatFunc :: IO ()
-- divide 100 GB by 100 MB/s
neatFunc = print $ timeDiv (fromPrefix 100 G B) (fromPrefix 10 M Bs)

someFunc :: IO ()
someFunc = do
         putStrLn "Gime the amount of data:"
         dat <- readLn
         putStrLn "Gime K for KB, M for MB, G for GB:"
         unit <- readLn
         let dataAmount = fromPrefix dat unit B
         putStrLn "Gime speed of data:"
         speed <- readLn
         putStrLn "Gime K for KB/s M for MB/s G for GB/s:"
         speedunit <- readLn
         let speedAmount = fromPrefix speed speedunit Bs
         let S result = timeDiv dataAmount speedAmount
         putStrLn $ "You need " ++ show result ++ " seconds"

unPrefix :: Prefix -> Double -> Double
unPrefix I x = x
unPrefix K x = x/1e3
unPrefix M x = x/1e6
unPrefix G x = x/1e9

example1 = print $ ks  -- answer in kiloseconds
  where ks = let S s = timeDiv (fromPrefix 100 G B) (fromPrefix 10 M Bs)
             in  unPrefix K s

-- Solution 5: "Enterprise" solution

{-# LANGUAGE DataKinds, GADTs, KindSignatures, PolyKinds, RankNTypes, StandaloneDeriving, TypeFamilies #-}

data Value (q :: Quantity) (p :: Prefix) where
  IValue :: Double -> Value q I
  KValue :: Double -> Value q K
  MValue :: Double -> Value q M
  GValue :: Double -> Value q G
data Quantity = DataAmount | Speed | Time | FileSize
data Prefix = I | K | M | G deriving (Show, Read)
deriving instance Show (Value q p)

data Unit = B | Bs | S deriving (Show)
type family QuantityUnit q where
  QuantityUnit DataAmount = B
  QuantityUnit FileSize = B
  QuantityUnit Speed = Bs
  QuantityUnit Time = S

convertToI :: Value q p -> Value q I
convertToI i@(IValue _) = i   -- no conversion needed
convertToI   (KValue x) = IValue (1e3*x)
convertToI   (MValue x) = IValue (1e6*x)
convertToI   (GValue x) = IValue (1e9*x)

timeDivI :: (QuantityUnit bytes ~ B, QuantityUnit bps ~ Bs, QuantityUnit secs ~ S)
         => Value bytes I -> Value bps I -> Value secs I
timeDivI (IValue bytes) (IValue bps)
  | bps > 0   = IValue (bytes / bps)
  | otherwise = error "TODO: replace with enterprisey exception"

timeDiv :: (QuantityUnit bytes ~ B, QuantityUnit bps ~ Bs, QuantityUnit secs ~ S, KnownPrefix p3)
         => Value bytes p1 -> Value bps p2 -> Value secs p3
timeDiv bytes bps = convertFromI $ timeDivI (convertToI bytes) (convertToI bps)

data SPrefix p where
  SI :: SPrefix I
  SK :: SPrefix K
  SM :: SPrefix M
  SG :: SPrefix G
deriving instance Show (SPrefix p)
convertFromI' :: SPrefix p -> Value q I -> Value q p
convertFromI' SI v = v
convertFromI' SK (IValue base) = KValue (base/1000)
convertFromI' SM (IValue base) = MValue (base/1000)
convertFromI' SG (IValue base) = GValue (base/1000)

class    KnownPrefix p where singPrefix :: SPrefix p
instance KnownPrefix I where singPrefix = SI
instance KnownPrefix K where singPrefix = SK
instance KnownPrefix M where singPrefix = SM
instance KnownPrefix G where singPrefix = SG

convertFromI :: (KnownPrefix p) => Value q I -> Value q p
convertFromI = convertFromI' singPrefix

awesomerFunc = do
  let dat   = GValue 1000 :: Value DataAmount G  -- 1000 gigabytes of data
      fs    = MValue 15   :: Value FileSize M    -- 15 megabytes in file
      speed = MValue 100  :: Value Speed M       -- 100 MB/s
      -- timeDiv works with DataAmount...
      time1 = timeDiv dat speed :: Value Time I  -- seconds
      -- ...and FileSize, with args having arbitrary prefixes...
      time2 = timeDiv fs speed  :: Value Time K  -- kiloseconds
      -- ...and can return values w/ arbitrary prefixes.
  print (time1, time2)

data SomeValue q where
  SomeValue :: SPrefix p -> Value q p -> SomeValue q
deriving instance Show (SomeValue q)

someValue :: Double -> Prefix -> SomeValue q
someValue x I = SomeValue SI (IValue x)
someValue x K = SomeValue SK (KValue x)
someValue x M = SomeValue SM (MValue x)
someValue x G = SomeValue SG (GValue x)

withSomeValue :: SomeValue q -> (forall p . Value q p -> a) -> a
withSomeValue sv f = case sv of
  SomeValue SI v -> f v
  SomeValue SK v -> f v
  SomeValue SM v -> f v
  SomeValue SG v -> f v

someFunc :: IO ()
someFunc = do
  putStrLn "Gime the amount of data:"
  dat <- readLn
  putStrLn "Gime K for KB, M for MB, G for GB:"
  unit <- readLn
  let dataAmount = someValue dat unit :: SomeValue DataAmount
  putStrLn "Gime speed of data:"
  speed <- readLn
  putStrLn "Gime K for KB/s M for MB/s G for GB/s:"
  speedunit <- readLn
  let speedAmount = someValue speed speedunit :: SomeValue Speed
  withSomeValue dataAmount $ \d -> withSomeValue speedAmount $ \s -> do
    let KValue ks = timeDiv d s :: Value Time K
    putStrLn $ "You need " ++ show ks ++ " kiloseconds"

Upvotes: 1

K. A. Buhr
K. A. Buhr

Reputation: 50884

Be warned, this isn't a very good way of approaching this problem.

However, if you really want to use GHC.Generics to define a generic convertToK, here's how you do it.

We'll need a lot of extensions and some modules:

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}

import Control.Applicative
import Data.Maybe
import Generics.Deriving.ConNames
import GHC.Generics

We'll define a Prefix data type given by:

data Prefix = K | M | G deriving (Show, Read, Eq)

Our goal will be to define a generic conversion function for the Scalable type class that makes use of three generic functions: (1) prefix to get the unit Prefix of a term; (2) value to get the Double hidden inside, whatever the prefix; and (3) makeK to build a kilo value of the right type. The generic conversion is easily defined in terms of these generic functions:

convertToK :: (Scalable a) => a -> a
convertToK x = case prefix x of
  K -> x
  M -> makeK (1000 * v)
  G -> makeK (1000000 * v)
  where v = value x

and here's the class with those functions and their signatures.

class Scalable a where
  prefix :: a -> Prefix   -- get the unit prefix
  value  :: a -> Double   -- get value regardless of prefix
  makeK  :: Double -> a   -- create a "kilo" value (i.e., the "kilo" constructor)

We can cheat a bit with prefix, since generic-deriving already provides a conNameOf function to get the name of a term's constructor. We can just pull off the first character and read it into a Prefix value using the following default implementation in this class:

  -- within class Scalable
  default prefix :: (Generic a, ConNames (Rep a)) => a -> Prefix
  prefix = read . take 1 . conNameOf

The value function will dispatch to the value' :: f x -> Double function (defined in the Value' type class below) in the usual way for GHC.Generics generic functions:

  -- within class Scalable
  default value :: (Generic a, Value' (Rep a)) => a -> Double
  value = value' . from

The makeK function is a little more complicated. Its generic version in the MakeK' type class has signature Double -> Maybe (f x), indicating that it might create a kilo value, if it's recursively found the correct constructor. So, this default definition just adapts makeK to that signature. It'll be clearer below.

  -- within class Scalable
  default makeK :: (Generic a, MakeK' (Rep a)) => Double -> a
  makeK = to . fromJust . makeK'

The Value' class is a relatively straightforward generic function:

class Value' f where
  value' :: f x -> Double

We handle sum types by recursing along whatever branch this term represents:

instance (Value' f, Value' g) => Value' (f :+: g) where
  value' (L1 x) = value' x
  value' (R1 x) = value' x

Eventually, we'll recurse into the Double and return it:

instance Value' (K1 c Double) where
  value' (K1 x) = x

Of course, we don't need any meta information, but we need an instance to skip it:

instance (Value' f) => Value' (M1 i t f) where
  value' (M1 x) = value' x

Note that we've left out instances for V1, U1, and K1s other than Double. We've also left out (:*:) product types. We don't intend to use this class with types that include any of those forms.

Now, we move to the definition for the MakeK' class. This one is structured quite differently, because instead of having a concrete term that we're deconstructing, we're trying to build a concrete term from a Double by finding the constructor that starts with "K" and using it.

class MakeK' f where
  makeK' :: Double -> Maybe (f x)

The first key point is how sum types are handled. We try to build a "K" term as a sum type by trying to build it as the left branch of the sum. If that succeeds (by returning a "Just" value), we know we've found and used the "K" constructor; otherwise, we try the right branch instead. (If that fails, too, there must be some higher level branch in the recursion that will succeed, so we just return "Nothing" to let it do its work.)

instance (MakeK' f, MakeK' g) => MakeK' (f :+: g) where
  makeK' n = L1 <$> makeK' n <|> R1 <$> makeK' n

The second key point is how we find the "K" constructor. We peek into constructor metadata at "C1" nodes using the following instance. It's set as overlapping as it should take precedence over the general metadata instance that ignores non-constructor metadata. You can see that makeK' depends on the boolean isK indicating that we found the "K" constructor. If isK is false, we stop the search and return Nothing. Otherwise, we recurse into the contents. Basically, the constructor metadata acts as a kind of gatekeeper that only lets through the Double from the "K" constructor and makes all the other constructors Nothing. That's how we end up with the right "K"-based term at the end. It might look a little backwards, but it seems like the right way to do it:

instance {-# OVERLAPPING #-} (Constructor c, MakeK' f) => MakeK' (C1 c f) where
  makeK' n | isK = M1 <$> makeK' n
           | otherwise = Nothing

The function isK itself is a little tricky. Remember that we aren't deconstructing an actual term. Instead, we're considering whether or not to build one, so we use an undefined placeholder here just for its type so we can call conName on it to get the constructor name for this branch. If its first letter is "K", we set isK true.

    where isK = head (conName (undefined :: C1 c f x)) == 'K'

As mentioned above, we need to ignore non-constructor metadata:

instance MakeK' f => MakeK' (M1 i t f) where
  makeK' n = M1 <$> makeK' n

and we need to handle the Double when we find it. Note that we unconditionally construct it here. The constructor metadata further up in the recursion has already made the decision that we're the Double for the right constructor.

instance MakeK' (K1 c Double) where
  makeK' n = Just $ K1 n

Anyway, after all that, we can define our data types and make them instances of the Scalable class:

data DataAmount = KB Double | MB Double | GB Double deriving (Generic, Show)
data Speed = KBs Double | MBs Double | GBs Double deriving (Generic, Show)
instance Scalable DataAmount
instance Scalable Speed

and the rest of your program looks like:

timeDiv (KB x) (KBs z) | z>0 = x/z
someFunc :: IO ()
someFunc = do
  putStrLn "Gime the amount of data:"
  dat <- readLn
  putStrLn "Gime 1 for KB 2 for MB 3 for GB:"
  unit <- readLn
  let dataAmount = case unit of
                     1 -> KB dat
                     2 -> MB dat
                     3 -> GB dat
                     _ -> KB dat
  putStrLn "Gime speed of data:"
  speed <- readLn
  putStrLn "Gime 1 for KB/s 2 for MB/s 3 for GB/s:"
  speedunit <- readLn
  let speedAmount = case speedunit of
                         1 -> KBs speed
                         2 -> MBs speed
                         3 -> GBs speed
                         _ -> KBs speed
  let speedAmountKBs = convertToK speedAmount
  let dataAmountKB = convertToK dataAmount
  let result = timeDiv dataAmountKB speedAmountKBs
  putStrLn $ "You need " ++ show result ++ " seconds"

There's clearly a lot wrong with this approach, though:

  • It's messy and complicated to write. You'd need a lot of instances to make this worthwhile.
  • It's pretty inefficient, as conversions require several passes through the representation tree.
  • It's not type safe. First, if we define a Scalable instance on a data type that doesn't obey the naming conventions, it'll cause a runtime error. Second, in your program, there's no type safety in the different units being passed around. If you remove one or both convertToK calls, the program will still type check but may generate a runtime error when timeDiv fails on a pattern match while trying to work with an unconverted value.

Anyway, the full program for reference is:

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}

import Control.Applicative
import Data.Maybe
import Generics.Deriving.ConNames
import GHC.Generics

data Prefix = K | M | G deriving (Show, Read, Eq)

convertToK :: (Scalable a) => a -> a
convertToK x = case prefix x of
  K -> x
  M -> makeK (1000 * v)
  G -> makeK (1000000 * v)
  where v = value x

class Scalable a where

  prefix :: a -> Prefix   -- get the unit prefix
  default prefix :: (Generic a, ConNames (Rep a)) => a -> Prefix
  prefix = read . take 1 . conNameOf

  value  :: a -> Double   -- get value regardless of prefix
  default value :: (Generic a, Value' (Rep a)) => a -> Double
  value = value' . from

  makeK  :: Double -> a   -- create a "kilo" value (i.e., the "kilo" constructor)
  default makeK :: (Generic a, MakeK' (Rep a)) => Double -> a
  makeK = to . fromJust . makeK'

class Value' f where
  value' :: f x -> Double
instance (Value' f, Value' g) => Value' (f :+: g) where
  value' (L1 x) = value' x
  value' (R1 x) = value' x
instance Value' (K1 c Double) where
  value' (K1 x) = x
instance (Value' f) => Value' (M1 i t f) where
  value' (M1 x) = value' x

class MakeK' f where
  makeK' :: Double -> Maybe (f x)
instance (MakeK' f, MakeK' g) => MakeK' (f :+: g) where
  makeK' n = L1 <$> makeK' n <|> R1 <$> makeK' n
instance {-# OVERLAPPING #-} (Constructor c, MakeK' f) => MakeK' (C1 c f) where
  makeK' n | isK = M1 <$> makeK' n
           | otherwise = Nothing
    where isK = head (conName (undefined :: C1 c f x)) == 'K'
instance MakeK' f => MakeK' (M1 i t f) where
  makeK' n = M1 <$> makeK' n
instance MakeK' (K1 c Double) where
  makeK' n = Just $ K1 n

data DataAmount = KB Double | MB Double | GB Double deriving (Generic, Show)
data Speed = KBs Double | MBs Double | GBs Double deriving (Generic, Show)
instance Scalable DataAmount
instance Scalable Speed

timeDiv (KB x) (KBs z) | z>0 = x/z

someFunc :: IO ()
someFunc = do
  putStrLn "Gime the amount of data:"
  dat <- readLn
  putStrLn "Gime 1 for KB 2 for MB 3 for GB:"
  unit <- readLn
  let dataAmount = case unit of
                     1 -> KB dat
                     2 -> MB dat
                     3 -> GB dat
                     _ -> KB dat
  putStrLn "Gime speed of data:"
  speed <- readLn
  putStrLn "Gime 1 for KB/s 2 for MB/s 3 for GB/s:"
  speedunit <- readLn
  let speedAmount = case speedunit of
                         1 -> KBs speed
                         2 -> MBs speed
                         3 -> GBs speed
                         _ -> KBs speed
  let speedAmountKBs = convertToK speedAmount
  let dataAmountKB = convertToK dataAmount
  let result = timeDiv dataAmountKB speedAmountKBs
  putStrLn $ "You need " ++ show result ++ " seconds"

Upvotes: 1

Daniel Wagner
Daniel Wagner

Reputation: 152867

I am generally in favor of enforcing things like unit equivalency at the type level. But you haven't done any of that here (yet), so I think your current approach is much too complicated for the level of guarantee you're getting.

You get a similar level of guarantee from the following significantly simpler code:

someFunc :: IO ()
someFunc = do
         putStrLn "Gime the amount of data:"
         dat <- readLn
         putStrLn "Gime 1 for KB 2 for MB 3 for GB:"
         datunit <- readLn
         putStrLn "Gime speed of data:"
         speed <- readLn
         putStrLn "Gime 1 for KB/s 2 for MB/s 3 for GB/s:"
         speedunit <- readLn
         let result = (dat * 1000^datunit) / (speed * 1000^speedunit)
         putStrLn $ "You need " ++ show result ++ " seconds"

Upvotes: 2

Related Questions