Skip to content

Instantly share code, notes, and snippets.

@lehins
Created January 16, 2020 01:26
Show Gist options
  • Save lehins/5a17e9d344d4fecd6fbc9aff0beda9b5 to your computer and use it in GitHub Desktop.
Save lehins/5a17e9d344d4fecd6fbc9aff0beda9b5 to your computer and use it in GitHub Desktop.
Currency and money at type level
{-# 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")
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment