Tax.hs

{-# Language DataKinds #-}
{-# Language FlexibleContexts #-}
{-# Language FlexibleInstances #-}
{-# Language KindSignatures #-}
{-# Language ScopedTypeVariables #-}
{-# Language TypeApplications #-}
{-# Language ViewPatterns #-}

module Tax where

import GHC.TypeLits
import Control.Monad
import Data.Foldable
import Data.List
import Data.Map (Map)
import Data.Proxy
import Data.Time

import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import qualified Data.Csv as Csv
import qualified Data.Map as Map
import qualified Data.Vector as V

data Asset = MKR | ETH | USD | EUR | SEK
  deriving (Eq, Ord, Show)

-- | E.g. `(ETH, 10) :-> (USD, 2000)`.
data Trade = (Asset, Double) :-> (Asset, Double)
  deriving (Eq, Ord, Show)

data DatedTrade = On Day Trade
  deriving (Eq, Ord, Show)

-- | The CSV library uses typeclasses in a way that forces us to have
-- distinct types for each CSV format; we use this type with a phantom
-- type parameter to do it without defining a bunch of useless types.
data TradeEntry (format :: Symbol) = TradeEntry Day Trade

-- | Associates an asset with a quantity and an average cost basis.
--
-- To support e.g. FIFO valuations, this would need to be a more
-- complex type.
type Inventory = Map Asset (Double, Double)


csvDayFormats :: [String]
csvDayFormats = ["%FT%T%z", "%m/%d/%Y", "%Y-%m-%d", "%Y-%m-%d %T %z"]

-- | This is just a day that we parse from CSV by trying
-- various formats.
newtype TxDate = TxDate Day
instance Csv.FromField TxDate where
  parseField (BS8.unpack -> s) =
    TxDate <$> asum
      [parseTimeM True defaultTimeLocale fmt s | fmt <- csvDayFormats]

mkTradeEntry :: Asset -> Asset -> TxDate -> Double -> Double -> TradeEntry fmt
mkTradeEntry a b (TxDate t) x y = TradeEntry t $ (a, x) :-> (b, y)

instance Csv.FromRecord (TradeEntry "Oasis") where
  parseRecord v =
    mkTradeEntry MKR ETH
      <$> Csv.index v 7 <*> Csv.index v 3 <*> Csv.index v 6

instance Csv.FromRecord (TradeEntry "Coinbase") where
  parseRecord v =
    mkTradeEntry ETH EUR
      <$> Csv.index v 0 <*> Csv.index v 3 <*> Csv.index v 5

instance Csv.FromRecord (TradeEntry "CoinbaseFiat") where
  parseRecord v =
    mkTradeEntry EUR EUR
      <$> Csv.index v 0 <*> (negate <$> Csv.index v 2) <*> Csv.index v 7

parseCsv :: forall a. Csv.FromRecord a => String -> IO [a]
parseCsv path = do
  csv <- BL.readFile path
  case Csv.decode @a Csv.HasHeader csv of
    Left s -> error s
    Right x -> pure (V.toList x)

parseTrades
  :: forall a. (Csv.FromRecord (TradeEntry a))
  => Proxy a -> String -> IO [DatedTrade]
parseTrades _ path =
  map f <$> parseCsv @(TradeEntry a) path
  where f (TradeEntry d t) = On d t

parseCoinbaseTrades =
  parseTrades (Proxy @"Coinbase")
parseCoinbaseFiatTrades =
  parseTrades (Proxy @"CoinbaseFiat")
parseOasisTrades =
  parseTrades (Proxy @"Oasis")

mergeTrades :: [DatedTrade] -> [DatedTrade]
mergeTrades xs =
  reverse (go [] (head xs) (tail xs))
  where
    go acc tx [] = tx:acc
    go acc (tx@(On t ((a, x) :-> (b, y)))) ((tx'@(On t' ((a', x') :-> (b', y')))):txs) =
      if (t, a, b) == (t', a', b')
      then go acc (On t ((a, x + x') :-> (b, y + y'))) txs
      else go (tx:acc) tx' txs

data YahooForexRow = YahooForexRow Day Double
  deriving Show

instance Csv.FromRecord YahooForexRow where
  parseRecord v = do
    TxDate day <- Csv.index v 0
    close <- Csv.index v 4
    return (YahooForexRow day close)

data EcbForexRow = EcbForexRow
  { ecb_day :: Day
  , eur_usd :: Double
  , eur_sek :: Double
  } deriving Show

instance Csv.FromRecord EcbForexRow where
  parseRecord v = do
    TxDate day <- Csv.index v 0
    EcbForexRow <$> pure day <*> Csv.index v 1 <*> Csv.index v 16

data Rate = Rate Day Asset Double Asset
  deriving (Eq, Ord, Show)

yahooRate :: Asset -> Asset -> YahooForexRow -> Rate
yahooRate a b (YahooForexRow t p) = Rate t a p b

ecbRates :: EcbForexRow -> [Rate]
ecbRates ecb =
  [ Rate (ecb_day ecb) EUR (eur_usd ecb) USD
  , Rate (ecb_day ecb) EUR (eur_sek ecb) SEK
  ]

findRate :: [Rate] -> Day -> Asset -> Asset -> Double
findRate rates day a b =
  case find (\(Rate day' a' _ b') -> day' <= day && a == a' && b == b') (reverse rates) of
    Nothing -> error ("no rate " ++ show (day, a, b))
    Just (Rate _ _ x _) -> x

inSEK :: (Asset -> Asset -> Double) -> Asset -> Double
inSEK rate asset =
  case asset of
    SEK -> 1
    EUR -> rate EUR SEK
    USD -> (1 / rate EUR USD) * inSEK rate EUR
    ETH -> rate ETH USD * inSEK rate USD

update :: (Asset -> Double) -> Trade -> Inventory -> Inventory
update value ((a, x) :-> (b, y)) basis =
  let
    p = (y / x) * value b
    (a_n', a_p') =
      case Map.lookup a basis of
        Nothing -> error ("no cost basis for " ++ show a)
        Just (a_n, a_p) ->
          (a_n - x, a_p)
    (b_n', b_p') =
      case Map.lookup b basis of
        Nothing ->
          (y, (x * p) / y)
        Just (b_n, b_p) ->
          (b_n + y, (b_n * b_p + x * p) / (b_n + y))
  in
    Map.insert a (a_n', a_p') (Map.insert b (b_n', b_p') basis)

data TaxTrade = TaxTrade
  { pair :: (Asset, Asset)
  , day :: Day
  , quantity :: Double
  , income :: Double
  , costBasis :: Double
  }
  deriving (Eq, Ord, Show)

profit :: TaxTrade -> Double
profit x = income x - costBasis x

foo :: (Day -> Asset -> Double) -> ([TaxTrade], Inventory) -> DatedTrade -> IO ([TaxTrade], Inventory)
foo valueOn (taxTrades, basis) (On t tx@((a, x) :-> (b, y))) = do
  putStrLn ""
  print t
  mapM_ (\x -> putStr " - " >> print x) (Map.toList basis)
  putStrLn ""
  putStrLn $ concat ["Sold ", show x, " ", show a, " for ", show y, " ", show b]
  
  let price = y / x * valueOn t b
  let basisPrice = snd (basis Map.! a)
  let costBasis = x * basisPrice
  let income = valueOn t b * y
  let profit = income - costBasis
  let taxTrade = TaxTrade (a, b) t x income costBasis
  
  putStrLn $ "A price:     " ++ show price ++ " SEK per " ++ show a
  when (b /= SEK) $
    putStrLn $ "B price:     " ++ show (valueOn t b) ++ " SEK per " ++ show b
  putStrLn $ "Basis price: " ++ show basisPrice ++ " SEK per " ++ show a
  putStrLn $ "Income:      " ++ show income ++ " SEK"
  putStrLn $ "Cost basis:  " ++ show costBasis ++ " SEK"
  putStrLn $ "Profit:      " ++ show profit ++ " SEK"
  putStrLn $ "Profit %:    " ++ show (100 * profit / costBasis)
  
  let basis' = update (valueOn t) tx basis
  putStrLn ""
  mapM_ (\x -> putStr " - " >> print x) (Map.toList basis')
  return (taxTrade : taxTrades, basis')

main :: IO ()
main = do
  trades <- concat <$> sequence
    [ parseCoinbaseTrades "coinbase.csv"
    , parseOasisTrades "2017-12 Oasis.csv"
    , parseOasisTrades "2018-04 Oasis.csv"
    , parseOasisTrades "2018-08 Oasis.csv"
    , parseOasisTrades "2018-10 Oasis.csv"
    ]

  fiatTrades <- parseCoinbaseFiatTrades "coinbase-eur.csv"

  ecb <- concatMap ecbRates <$> parseCsv @EcbForexRow "eurofx.csv"
  eth_usd <- map (yahooRate ETH USD) <$> parseCsv @YahooForexRow "ETH-USD.csv"

  let rates = sort (ecb ++ eth_usd)
  let basis = Map.singleton MKR (3000, 133.0)

  let sekValue t a = inSEK (findRate rates t) a

  -- The Coinbase fiat withdrawals are read as trading EUR for EUR...
  let fiatTrades' = map (\(On t ((EUR, x) :-> (EUR, y))) -> (On t ((EUR, x) :-> (SEK, sekValue t EUR * y)))) fiatTrades
  let mergedTrades = mergeTrades (sort (trades ++ fiatTrades'))

  let pastTrades = filter (\(On t _) -> t < fromGregorian 2019 1 1) mergedTrades

  let trades2018 = filter (\(On t _) -> t >= fromGregorian 2018 1 1) mergedTrades
  let trades2017 = filter (\(On t _) -> t < fromGregorian 2018 1 1) mergedTrades
      
  (tx2017, basis') <- foldM (foo sekValue) ([], basis) trades2017
  (tx2018, basis'') <- foldM (foo sekValue) ([], basis') trades2018

  putStrLn "Taxes\n"

  putStrLn "\n2017\n"
  groupify sekValue basis tx2017
  putStrLn "\n2018\n"
  groupify sekValue basis' tx2018

groupify sekValue basis xs = do
  let groups = groupBy (\x y -> pair x == pair y) (sort xs)
  mapM_ summarize groups

summarize :: [TaxTrade] -> IO ()
summarize xs =
  let
    (losses, profits) = partition (\x -> profit x < 0) xs
    sumField f x = sum (map f x)
  in do

    putStrLn ""
    putStrLn $ show (pair (head xs))
    
    putStrLn $ "Loss quantity: " ++ show (sumField quantity losses)
    putStrLn $ "Loss income: " ++ show (sumField income losses)
    putStrLn $ "Loss cost basis: " ++ show (sumField costBasis losses)
    putStrLn $ "Loss result " ++ show (sumField profit losses)

    putStrLn $ "Profit quantity: " ++ show (sumField quantity profits)
    putStrLn $ "Profit income: " ++ show (sumField income profits)
    putStrLn $ "Profit cost basis: " ++ show (sumField costBasis profits)
    putStrLn $ "Profit result " ++ show (sumField profit profits)
    
    putStrLn $ "Total income: " ++ show (sumField income xs)
    putStrLn $ "Total profit: " ++ show (sumField profit xs)