Singletons, Classes, etc.

UnitLength.hs

{-# LANGUAGE DataKinds      #-}
{-# LANGUAGE GADTs          #-}
{-# LANGUAGE KindSignatures #-}

module UnitLength where

newtype Length (a::UnitLength) b = Length { payload :: b } deriving (Eq,Show)
data UnitLength = Meter
                | KiloMeter
                | Miles
                deriving (Eq,Show)

data SUnitLength (a :: UnitLength) where
  SMeter     :: SUnitLength Meter
  SKiloMeter :: SUnitLength KiloMeter
  SMiles     :: SUnitLength Miles

display :: Show b => SUnitLength a -> Length a b -> String
display sa l = show (payload l) ++
  case sa of
    SKiloMeter -> "km"
    _          -> "m"

class CUnitLength (a :: UnitLength) where
  getUnit :: Length a b -> SUnitLength a

instance CUnitLength Meter where
  getUnit _ = SMeter

instance CUnitLength KiloMeter where
  getUnit _ = SKiloMeter

instance CUnitLength Miles where
  getUnit _ = SMiles

getUnit' :: CUnitLength a => SUnitLength a
getUnit' = getUnit (undefined :: Length a ())

display' :: (CUnitLength a, Show b) => Length a b -> String
display' = display getUnit'