commodities 0.0.1 → 0.1.0
raw patch · 7 files changed
+118/−62 lines, 7 filesdep +mtl
Dependencies added: mtl
Files
- Ledger/Balance.hs +3/−0
- Ledger/Commodity.hs +35/−25
- Ledger/Commodity/History.hs +16/−18
- Ledger/Commodity/Parse.hs +9/−0
- Ledger/Commodity/Print.hs +38/−0
- commodities.cabal +4/−1
- test/Main.hs +13/−18
Ledger/Balance.hs view
@@ -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)
Ledger/Commodity.hs view
@@ -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)
Ledger/Commodity/History.hs view
@@ -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
+ Ledger/Commodity/Parse.hs view
@@ -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
+ Ledger/Commodity/Print.hs view
@@ -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 ()
commodities.cabal view
@@ -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
test/Main.hs view
@@ -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