diff --git a/Ledger/Balance.hs b/Ledger/Balance.hs --- a/Ledger/Balance.hs +++ b/Ledger/Balance.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -47,6 +48,8 @@ | Amount Commodity a -- ^ A single commoditized amount | Balance (IntMap a) -- ^ A vector-space over commodities deriving (Eq, Ord, Show, Read, Typeable, Data) + +makePrisms ''Balance non' :: a -> Iso' (Maybe a) a non' = flip anon (const False) diff --git a/Ledger/Commodity.hs b/Ledger/Commodity.hs --- a/Ledger/Commodity.hs +++ b/Ledger/Commodity.hs @@ -3,16 +3,19 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Ledger.Commodity ( Commodity - , CommodityInfo(..) + , CommodityInfo(..), HasCommodityInfo(..) , defaultCommodityInfo - , CommodityMap(..) + , CommodityMap(..), HasCommodityMap(..) + , extendByDigits ) where +import Control.Lens import Data.IntMap (IntMap, Key) import qualified Data.IntMap as IntMap import Data.Map (Map) @@ -26,45 +29,52 @@ -- such commodities to the information known about them. type Commodity = Key +extendByDigits :: Int +extendByDigits = 6 + -- | All of the information known about a commodity. data CommodityInfo = CommodityInfo - { commSymbol :: !Text - , commPrecision :: !Int - , commSuffixed :: !Bool - , commSeparated :: !Bool - , commThousands :: !Bool - , commDecimalComma :: !Bool - , commNoMarket :: !Bool - , commBuiltin :: !Bool - , commKnown :: !Bool - , commPrimary :: !Bool - , commHistory :: !(IntMap (Map UTCTime Rational)) + { _commSymbol :: !Text + , _commPrecision :: !Int + , _commSuffixed :: !Bool + , _commSeparated :: !Bool + , _commThousands :: !Bool + , _commDecimalComma :: !Bool + , _commNoMarket :: !Bool + , _commBuiltin :: !Bool + , _commKnown :: !Bool + , _commPrimary :: !Bool + , _commHistory :: !(IntMap (Map UTCTime Rational)) } deriving (Eq, Read, Show) +makeClassy ''CommodityInfo + -- | Return a 'CommodityInfo' with defaults selected for all fields. It is -- intended that at least one field of the result will be modified -- immediately. defaultCommodityInfo :: CommodityInfo defaultCommodityInfo = CommodityInfo - { commSymbol = "" - , commPrecision = 0 - , commSuffixed = False - , commSeparated = False - , commThousands = True - , commDecimalComma = False - , commNoMarket = False - , commBuiltin = False - , commKnown = False - , commPrimary = False - , commHistory = IntMap.empty + { _commSymbol = "" + , _commPrecision = 0 + , _commSuffixed = False + , _commSeparated = False + , _commThousands = True + , _commDecimalComma = False + , _commNoMarket = False + , _commBuiltin = False + , _commKnown = False + , _commPrimary = False + , _commHistory = IntMap.empty } -- | A commodities map, relating commodity indices to information about -- those commodities. data CommodityMap = CommodityMap - { commodities :: IntMap CommodityInfo + { _commodities :: !(IntMap CommodityInfo) } deriving (Eq, Read, Show) + +makeClassy ''CommodityMap instance Semigroup CommodityMap where CommodityMap x <> CommodityMap y = CommodityMap (x <> y) diff --git a/Ledger/Commodity/History.hs b/Ledger/Commodity/History.hs --- a/Ledger/Commodity/History.hs +++ b/Ledger/Commodity/History.hs @@ -16,6 +16,7 @@ ) where import Control.Applicative +import Control.Lens import Control.Monad hiding (forM) import Control.Monad.Trans.State import Data.Functor.Identity @@ -142,10 +143,10 @@ -> UTCTime -- ^ Look for conversions on or before this -> CommodityMap -- ^ Set of commodities to search -> Maybe (UTCTime, Rational) -findConversion from to time cm = +findConversion f t time cm = let (keyPath, valuesMap) = flip runState IntMap.empty $ - intAStarM g h (return . (== to)) (return from) + intAStarM g h (return . (== t)) (return f) in go valuesMap <$> keyPath where g c = do @@ -154,35 +155,32 @@ (\(!m', !sm') k cs -> case Map.lookupLE time cs of Nothing -> (m', sm') - Just (t,r) -> - (IntMap.insert k (diffUTCTime time t) m', - IntMap.insert k (t, r) sm')) + Just (u,r) -> + (IntMap.insert k (diffUTCTime time u) m', + IntMap.insert k (u, r) sm')) (IntMap.empty, IntMap.empty) - (commHistory $ commodities cm IntMap.! c) + (cm ^. commodities.ix c.commHistory) put $! IntMap.insert c sm vm return m h _goal = return 0 - go vm ks = (\(!x, !y, _) -> (x, y)) $ foldl' f (time, 1, from) ks + go vm ks = (\(!x, !y, _) -> (x, y)) $ foldl' h (time, 1, f) ks where - f (!w, !r, !s) t = let (w', r') = vm IntMap.! s IntMap.! t - in (min w w', r / r', t) + h (!w, !r, !s) u = let (w', r') = vm IntMap.! s IntMap.! u + in (min w w', r / r', u) -- | Add a price conversion in the form of a ratio between two commodities at -- a specific point in time. addConversion :: Commodity -> Commodity -> UTCTime -> Rational -> State CommodityMap () -addConversion from to time ratio = - modify $ \(commodities -> cm) -> - CommodityMap $ update (1/ratio) to from $ update ratio from to cm +addConversion f t time ratio = do + commodities.at t %= fmap (addconv (1/ratio) ?? f) + commodities.at f %= fmap (addconv ratio ?? t) where - update r s t = IntMap.adjust (flip (addconv r) t) s - addconv r s t = - let c = commHistory s - mm = IntMap.lookup t c - rm = case mm of + let c = s^.commHistory + rm = case IntMap.lookup t c of Nothing -> Map.singleton time r Just m -> Map.insert time r m - in s { commHistory = IntMap.insert t rm c } + in s & commHistory .~ IntMap.insert t rm c diff --git a/Ledger/Commodity/Parse.hs b/Ledger/Commodity/Parse.hs new file mode 100644 --- /dev/null +++ b/Ledger/Commodity/Parse.hs @@ -0,0 +1,9 @@ +module Ledger.Commodity.Parse where + +import Control.Monad.Trans.State +import Data.Text +import Ledger.Balance +import Ledger.Commodity + +parseAmount :: Text -> State CommodityMap (Balance a) +parseAmount _str = undefined diff --git a/Ledger/Commodity/Print.hs b/Ledger/Commodity/Print.hs new file mode 100644 --- /dev/null +++ b/Ledger/Commodity/Print.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Ledger.Commodity.Print where + +import Control.Applicative +import Control.Lens +import Control.Monad.Reader.Class +import Control.Monad.Trans.Writer +import qualified Data.IntMap.Strict as IntMap +import Data.Text.Lazy +import Data.Text.Lazy.Builder +import Ledger.Balance +import Ledger.Commodity + +printAmount :: (MonadReader CommodityMap m, Functor m, Show a) + => Balance a + -> m Text +printAmount Zero = return "0" +printAmount (Plain x) = return $ pack (show x) +printAmount x = toLazyText <$> execWriterT (buildAmount x) + +buildAmount :: (MonadReader CommodityMap m, Show a) + => Balance a + -> WriterT Builder m () +buildAmount (Amount c q) = do + mcomm <- view (commodities.at c) + case mcomm of + Nothing -> error "Attempted to print an unknown commodity" + Just comm -> do + tell $ fromText (comm^.commSymbol) + tell $ fromString (show q) + +buildAmount (Balance xs) = + mapM_ (buildAmount . uncurry Amount) $ IntMap.toList xs + +buildAmount _ = return () diff --git a/commodities.cabal b/commodities.cabal --- a/commodities.cabal +++ b/commodities.cabal @@ -1,5 +1,5 @@ Name: commodities -Version: 0.0.1 +Version: 0.1.0 Synopsis: Library for working with commoditized amounts and price histories Description: Library for working with commoditized amounts and price histories License-file: LICENSE @@ -21,6 +21,8 @@ Ledger.Balance Ledger.Commodity Ledger.Commodity.History + Ledger.Commodity.Parse + Ledger.Commodity.Print build-depends: base >= 3 && < 5 , PSQueue @@ -30,6 +32,7 @@ , keys >= 3.0.2 , lens >= 3.7 , linear >= 0.7 + , mtl , numbers >= 2009.8.9 , representable-functors >= 3.0.1 , semigroups diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -53,23 +53,20 @@ oneDayAgo = addUTCTime (-(24 * 3600)) now usd = (defaultPrimary "USD") - { commHistory = + & commHistory .~ IntMap.fromList [ (2, Map.fromList [(oneHourAgo, 0.75)]) , (3, Map.fromList [(oneDayAgo, 0.66)]) ] - } cad = (defaultPrimary "CAD") - { commHistory = + & commHistory .~ IntMap.fromList [ (1, Map.fromList [(oneHourAgo, 1.33)]) , (3, Map.fromList [(oneHourAgo, 0.83)]) ] - } eur = (defaultPrimary "EUR") - { commHistory = + & commHistory .~ IntMap.fromList [ (1, Map.fromList [(oneDayAgo, 1.5)]) , (2, Map.fromList [(oneHourAgo, 1.2)]) ] - } in CommodityMap $ IntMap.fromList [ (1, usd) , (2, cad) @@ -77,12 +74,11 @@ ] where defaultPrimary sym = defaultCommodityInfo - { commSymbol = sym - , commPrecision = 2 - , commNoMarket = True - , commKnown = True - , commPrimary = True - } + & commSymbol .~ sym + & commPrecision .~ 2 + & commNoMarket .~ True + & commKnown .~ True + & commPrimary .~ True testMap' :: UTCTime -> CommodityMap testMap' now = @@ -103,9 +99,8 @@ addConversion 2 3 oneHourAgo (5 % 6) where defaultPrimary sym = defaultCommodityInfo - { commSymbol = sym - , commPrecision = 2 - , commNoMarket = True - , commKnown = True - , commPrimary = True - } + & commSymbol .~ sym + & commPrecision .~ 2 + & commNoMarket .~ True + & commKnown .~ True + & commPrimary .~ True