Currency and money at type level

TypeLevelMoney.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

import Data.Foldable
import Data.Proxy
import Data.Typeable
import Control.Applicative
import Data.Kind

-- Solutions to: https://www.reddit.com/r/haskell/comments/ep2ttt/static_types_are_dangerous/

data Currency
  = USD
  | GBP
  | JPY
  deriving (Eq, Ord, Show)

newtype Ticker =
  Ticker String
  deriving (Show)

newtype Money (currency :: Currency) = Money
  { unMoney :: Rational
  } deriving (Show)

data Trade (ccy :: Currency) = Trade
  { tQty :: Rational
  , tPrice :: Money ccy
  , tTicker :: Ticker
  } deriving (Show)

plus :: Money ccy -> Money ccy -> Money ccy
plus m1 m2 = Money (unMoney m1 + unMoney m2)

multiply :: Money ccy -> Rational -> Money ccy
multiply m1 v = Money (unMoney m1 * v)


data UnknownTrade
  = UsdTrade (Trade 'USD)
  | GbpTrade (Trade 'GBP)
  | JpyTrade (Trade 'JPY)
  deriving Show

data Notionals = Notionals
  { usdNotional :: Maybe (Money 'USD)
  , gbpNotional :: Maybe (Money 'GBP)
  , jpyNotional :: Maybe (Money 'JPY)
  } deriving Show

instance Semigroup Notionals where
  (<>) n1 n2 =
    Notionals
      { usdNotional = maybePlus (usdNotional n1) (usdNotional n2)
      , gbpNotional = maybePlus (gbpNotional n1) (gbpNotional n2)
      , jpyNotional = maybePlus (jpyNotional n1) (jpyNotional n2)
      }
    where
      maybePlus :: Maybe (Money ccy) -> Maybe (Money ccy) -> Maybe (Money ccy)
      maybePlus mm1 mm2 = (plus <$> mm1 <*> mm2) <|> mm1 <|> mm2

instance Monoid Notionals where
  mempty = Notionals Nothing Nothing Nothing

toNotional :: UnknownTrade -> Notionals
toNotional ut =
  case ut of
    UsdTrade trade -> mempty { usdNotional = Just $ tradeToNotional trade }
    GbpTrade trade -> mempty { gbpNotional = Just $ tradeToNotional trade }
    JpyTrade trade -> mempty { jpyNotional = Just $ tradeToNotional trade }

sumNotionals :: [UnknownTrade] -> Notionals
sumNotionals = foldMap toNotional

tradeToNotional :: Trade ccy -> Money ccy
tradeToNotional trade = tPrice trade `multiply` tQty trade

lookupNotional ::
     forall ccy. Typeable ccy
  => Notionals
  -> Proxy (ccy :: Currency)
  -> Maybe (Money ccy)
lookupNotional n _ =
  msum
    [ do Refl <- eqT :: Maybe (Money ccy :~: Money 'USD)
         usdNotional n
    , do Refl <- eqT :: Maybe (Money ccy :~: Money 'GBP)
         gbpNotional n
    , do Refl <- eqT :: Maybe (Money ccy :~: Money 'JPY)
         jpyNotional n
    ]

lookupNotional' ::
     forall ccy. Typeable ccy
  => Notionals
  -> Currency
  -> Maybe (Money ccy)
lookupNotional' n _ =
  msum
    [ do Refl <- eqT :: Maybe (Money ccy :~: Money 'USD)
         usdNotional n
    , do Refl <- eqT :: Maybe (Money ccy :~: Money 'GBP)
         gbpNotional n
    , do Refl <- eqT :: Maybe (Money ccy :~: Money 'JPY)
         jpyNotional n
    ]


trades :: [UnknownTrade]
trades =
  [ GbpTrade (Trade 100 (Money 1) (Ticker "VOD.L"))
  , GbpTrade (Trade 200 (Money 2) (Ticker "VOD.L"))
  , UsdTrade (Trade 300 (Money 3) (Ticker "AAPL.O"))
  , JpyTrade (Trade 50 (Money 5) (Ticker "4151.T"))
  ]

-------------------------------
-- Fully type level solution --
-------------------------------

infixr 5 :>, %+


-- | Add a trade to notionals
--
-- >>> a = Trade 200 (Money 1 :: Money 'GBP) (Ticker "VOD.L")
-- >>> b = Trade 200 (Money 2 :: Money 'GBP) (Ticker "VOD.L")
-- >>> c = Trade 300 (Money 3 :: Money 'USD) (Ticker "AAPL.O")
-- >>> a %+ b %+ c %+ HNil
-- Money {unMoney = 900 % 1} :> Money {unMoney = 600 % 1} :> HNil
--
(%+) ::
     forall x xs. AddNotional (IsHead x xs) x xs
  => Trade x
  -> HNotional xs
  -> HNotional (SnocUnique (IsHead x xs) xs x)
(%+) = addNotional' @(IsHead x xs)

-- | Look up notional with currency
--
-- >>> a = Trade 200 (Money 1 :: Money 'GBP) (Ticker "VOD.L")
-- >>> b = Trade 200 (Money 2 :: Money 'GBP) (Ticker "VOD.L")
-- >>> c = Trade 300 (Money 3 :: Money 'USD) (Ticker "AAPL.O")
-- >>> foo = a %+ b %+ c %+ HNil
-- >>> getNotional foo :: Money 'USD
-- Money {unMoney = 900 % 1}
-- >>> getNotional foo :: Money 'GBP
-- Money {unMoney = 600 % 1}
-- >>> getNotional foo :: Money 'JPY -- <- Compile error
--
getNotional ::
     forall x xs. GetNotional (IsHead x xs) x xs
  => HNotional xs
  -> Money x
getNotional = getNotional' @(IsHead x xs)

type family SnocUnique (isHead :: Bool) (xs :: [Currency]) (x :: Currency) where
  SnocUnique _ '[] x = '[x]
  SnocUnique 'True (x ': xs) x = x ': xs
  SnocUnique 'False (y ': xs) x = y ': SnocUnique (IsHead x xs) xs x

type family IsHead (x :: Currency) (xs :: [Currency]) :: Bool where
  IsHead x (x ': xs) = 'True
  IsHead x xs = 'False

data HNotional (as :: [Currency]) where
  HNil :: HNotional '[]
  (:>) :: Money (a :: Currency) -> HNotional as -> HNotional (a ': as)

instance Show (HNotional '[]) where
  show HNil = "HNil"
instance Show (HNotional xs) => Show (HNotional (x ': xs)) where
  show (x :> xs) = show x ++ " :> " ++ show xs

class AddNotional (isHead :: Bool) x xs where
  addNotional' :: Trade x -> HNotional xs -> HNotional (SnocUnique isHead xs x)

instance AddNotional 'False x '[] where
  addNotional' t HNil = tradeToNotional t :> HNil

instance AddNotional 'True x (x ': xs :: [Currency]) where
  addNotional' t (m :> xs) = plus m (tradeToNotional t) :> xs

instance AddNotional (IsHead x xs) x xs => AddNotional 'False x (y ': xs :: [Currency]) where
  addNotional' t (m :> xs) = m :> addNotional' @(IsHead x xs) t xs

class GetNotional (isHead :: Bool) x xs where
  getNotional' :: HNotional xs -> Money x

instance GetNotional 'True x (x ': xs) where
  getNotional' (m :> _) = m

instance GetNotional (IsHead x xs) x xs =>
         GetNotional 'False x (y ': xs) where
  getNotional' (_ :> xs) = getNotional' @(IsHead x xs) xs


ttrades :: HNotional '[ 'USD, 'GBP, 'JPY]
ttrades = d %+ ttradesNoJPY
  where
    d = Trade 50 (Money 5 :: Money 'JPY) (Ticker "4151.T")

ttradesNoJPY :: HNotional '[ 'USD, 'GBP]
ttradesNoJPY = a %+ b %+ c %+ HNil
  where
    a = Trade 200 (Money 1 :: Money 'GBP) (Ticker "VOD.L")
    b = Trade 200 (Money 2 :: Money 'GBP) (Ticker "VOD.L")
    c = Trade 300 (Money 3 :: Money 'USD) (Ticker "AAPL.O")