phantom types

phantom_types.hs

{- Fun with phantom types. Type safe doubles. #-}

-- this lets us derive the Num implementation
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}

-- P stands for Phantom, or Parametrized type
newtype P a b = Wrap { unwrap :: b } deriving Num
deriving instance Floating b => Floating (P a b)
deriving instance Fractional b => Fractional (P a b)

-- this could be used as a shortcut, e.g. P Price Double == PD Price
type PD a = P a Double

instance Show b => Show (P a b) where
  show = show . unwrap

data Price
data LogRet
data SimpleRet
data PctRet

-- this should not be exported.
unsafeCast :: P a c -> P b c
unsafeCast = Wrap . unwrap

-- safe functions for converting between each other

-- this type signature could be written PD Price -> PD Price -> PD LogRet
-- write out full types for clarity.
logRet :: P Price Double -> P Price Double -> P LogRet Double
logRet old new = unsafeCast . log $ new / old -- log and (/) work correctly!

simple2LogRet :: P SimpleRet Double -> P LogRet Double
simple2LogRet = unsafeCast . log

log2SimpleRet :: P LogRet Double -> P SimpleRet Double
log2SimpleRet = unsafeCast . exp

simple2PctRet :: P SimpleRet Double -> P PctRet Double
simple2PctRet = unsafeCast . (+1)

pct2SimpleRet :: P PctRet Double -> P SimpleRet Double
pct2SimpleRet = unsafeCast . (\x -> x - 1)

cumulativeLogRet :: [P LogRet Double] -> P LogRet Double
cumulativeLogRet = foldl (+) 0

cumulativeSimpleRet :: [P SimpleRet Double] -> P SimpleRet Double
cumulativeSimpleRet = foldl (*) 1


------------------------------------
-- External 'application'
------------------------------------
prices :: [P Price Double]
prices = Wrap <$> [1,1.1,0.9,0.99]

main = do
  print $ logRet 1 2 + logRet 2 3 -- (+) works correctly!
  -- print $ logRet (logRet 1 2) (logRet 2 3) -- no compile

  let logrets = zipWith logRet prices (tail prices)
  print $ cumulativeLogRet logrets

  let confusinglyNamedVariable = prices
  -- print $ cumulativeLogRet confusinglyNamedVariable -- no compile

  -- print $ cumulativeSimpleRet logrets -- no compile
  let simpleRets = log2SimpleRet <$> logrets
  print $ cumulativeSimpleRet $ simpleRets

  -- let pctRets = simple2PctRet <$> simpleRets
  -- print $ cumulativeSimpleRet pctRets -- no compile