commodities 0.2.0 → 0.2.0.1
raw patch · 8 files changed
+177/−91 lines, 8 filesdep +failuredep +parsersdep +splitdep ~PSQueuedep ~containersdep ~directorysetup-changed
Dependencies added: failure, parsers, split, trifecta
Dependency ranges changed: PSQueue, containers, directory, distributive, doctest, filepath, keys, linear, mtl, numbers, semigroups, text, thyme
Files
- Ledger/Balance.hs +37/−29
- Ledger/Commodity.hs +30/−3
- Ledger/Commodity/History.hs +5/−6
- Ledger/Commodity/Parse.hs +28/−6
- Ledger/Commodity/Print.hs +53/−13
- Setup.hs +0/−0
- commodities.cabal +18/−14
- test/Main.hs +6/−20
Ledger/Balance.hs view
@@ -20,10 +20,12 @@ , insert , delete , balanceStore+ , BalanceError(..) ) where import Control.Applicative import "comonad" Control.Comonad.Trans.Store+import Control.Exception import Control.Lens hiding (from, to) import qualified Control.Lens.Internal as Lens import Control.Monad hiding (forM)@@ -34,6 +36,7 @@ import qualified Data.IntMap as IntMap import qualified Data.Key as K import Data.Semigroup+import Data.Text (Text) import Data.Traversable import Ledger.Commodity import Linear.Vector@@ -52,8 +55,8 @@ makePrisms ''Balance -non' :: a -> Iso' (Maybe a) a-non' = flip anon (const False)+non'' :: a -> Iso' (Maybe a) a+non'' = flip anon (const False) -- instance Num a => Num (Balance a) where -- x + y = x ^+^ y@@ -87,8 +90,8 @@ Amount cx qx ^+^ Amount cy qy | cx == cy = Amount cx (qx + qy) | otherwise = Balance $ IntMap.fromList [(cx,qx), (cy,qy)]- Amount cx qx ^+^ Balance ys = Balance $ ys & at cx.non' 0 +~ qx- Balance xs ^+^ Amount cy qy = Balance $ xs & at cy.non' 0 +~ qy+ Amount cx qx ^+^ Balance ys = Balance $ ys & at cx.non'' 0 +~ qx+ Balance xs ^+^ Amount cy qy = Balance $ xs & at cy.non'' 0 +~ qy Balance xs ^+^ Balance ys = Balance $ xs ^+^ ys {-# INLINE (^+^) #-}@@ -198,34 +201,34 @@ type instance Index (Balance a) = Int type instance IxValue (Balance a) = a-instance Applicative f => Ixed f (Balance a) where- ix _k _f Zero = pure Zero- ix _k _f pl@(Plain _) = pure pl- ix k f amt@(Amount c q)- | k == c = Amount c <$> (Lens.indexed f k q <&> id)- | otherwise = pure amt- ix k f bal@(Balance xs) = case IntMap.lookup k xs of- Just v -> Balance- <$> (Lens.indexed f k v <&> \v' -> IntMap.insert k v' xs)- Nothing -> pure bal+-- instance Applicative f => Ixed f (Balance a) where+-- ix _k _f Zero = pure Zero+-- ix _k _f pl@(Plain _) = pure pl+-- ix k f amt@(Amount c q)+-- | k == c = Amount c <$> (Lens.indexed f k q <&> id)+-- | otherwise = pure amt+-- ix k f bal@(Balance xs) = case IntMap.lookup k xs of+-- Just v -> Balance+-- <$> (Lens.indexed f k v <&> \v' -> IntMap.insert k v' xs)+-- Nothing -> pure bal -instance At (Balance a) where- at k f m = Lens.indexed f k mv <&> \r -> case r of- Nothing -> maybe m (const (delete k m)) mv- Just v' -> insert k v' m- where mv = K.lookup k m+-- instance At (Balance a) where+-- at k f m = Lens.indexed f k mv <&> \r -> case r of+-- Nothing -> maybe m (const (delete k m)) mv+-- Just v' -> insert k v' m+-- where mv = K.lookup k m -instance (Contravariant f, Functor f) => Contains f (Balance a) where- contains = containsLookup K.lookup- {-# INLINE contains #-}+-- instance (Contravariant f, Functor f) => Contains f (Balance a) where+-- contains = containsLookup K.lookup+-- {-# INLINE contains #-} -instance Applicative f => Each f (Balance a) (Balance b) a b where- each _ Zero = pure Zero- each f (Plain q) = Plain <$> Lens.indexed f noCommodity q- each f (Amount c q) = Amount c <$> Lens.indexed f c q- each f (Balance m) = sequenceA $ Balance $ IntMap.mapWithKey f' m- where f' = Lens.indexed f- {-# INLINE each #-}+-- instance Applicative f => Each f (Balance a) (Balance b) a b where+-- each _ Zero = pure Zero+-- each f (Plain q) = Plain <$> Lens.indexed f noCommodity q+-- each f (Amount c q) = Amount c <$> Lens.indexed f c q+-- each f (Balance m) = sequenceA $ Balance $ IntMap.mapWithKey f' m+-- where f' = Lens.indexed f+-- {-# INLINE each #-} instance FunctorWithIndex Int Balance where imap = iover itraversed@@ -301,3 +304,8 @@ balanceSum :: Num a => [Balance a] -> Balance a balanceSum = Foldable.foldr (^+^) Zero++data BalanceError = BalanceParseError Text+ deriving (Show, Typeable)++instance Exception BalanceError
Ledger/Commodity.hs view
@@ -10,7 +10,7 @@ module Ledger.Commodity ( Commodity , CommodityInfo(..), HasCommodityInfo(..)- , defaultCommodityInfo+ , defaultCommodityInfo, defaultPrimaryCommodityInfo , CommodityMap(..), HasCommodityMap(..) , extendByDigits ) where@@ -49,6 +49,24 @@ makeClassy ''CommodityInfo +instance Semigroup CommodityInfo where+ x <> y = x+ & commSymbol .~ y^.commSymbol+ & commPrecision .~ max (x^.commPrecision) (y^.commPrecision)+ & commSuffixed .~ (x^.commSuffixed || y^.commSuffixed)+ & commSeparated .~ (x^.commSeparated || y^.commSeparated)+ & commThousands .~ (x^.commThousands || y^.commThousands)+ & commDecimalComma .~ (x^.commDecimalComma || y^.commDecimalComma)+ & commNoMarket .~ (x^.commNoMarket || y^.commNoMarket)+ & commBuiltin .~ (x^.commBuiltin || y^.commBuiltin)+ & commKnown .~ (x^.commKnown || y^.commKnown)+ & commPrimary .~ (x^.commPrimary || y^.commPrimary)+ & commHistory .~ (x^.commHistory <> y^.commHistory)++instance Monoid CommodityInfo where+ mempty = defaultCommodityInfo+ x `mappend` y = x <> y+ -- | Return a 'CommodityInfo' with defaults selected for all fields. It is -- intended that at least one field of the result will be modified -- immediately.@@ -57,7 +75,7 @@ { _commSymbol = "" , _commPrecision = 0 , _commSuffixed = False- , _commSeparated = False+ , _commSeparated = True , _commThousands = True , _commDecimalComma = False , _commNoMarket = False@@ -67,6 +85,14 @@ , _commHistory = IntMap.empty } +defaultPrimaryCommodityInfo :: Text -> CommodityInfo+defaultPrimaryCommodityInfo sym = defaultCommodityInfo+ & commSymbol .~ sym+ & commPrecision .~ 2+ & commNoMarket .~ True+ & commKnown .~ True+ & commPrimary .~ True+ -- | A commodities map, relating commodity indices to information about -- those commodities. data CommodityMap = CommodityMap@@ -77,7 +103,8 @@ makeClassy ''CommodityMap instance Semigroup CommodityMap where- CommodityMap x <> CommodityMap y = CommodityMap (x <> y)+ CommodityMap x <> CommodityMap y =+ CommodityMap (IntMap.unionWith (<>) x y) instance Monoid CommodityMap where mempty = CommodityMap mempty
Ledger/Commodity/History.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-} module Ledger.Commodity.History ( findConversion@@ -165,9 +164,9 @@ h _goal = return 0 - go vm ks = (\(!x, !y, _) -> (x, y)) $ foldl' h (time, 1, f) ks+ go vm ks = (\(!x, !y, _) -> (x, y)) $ foldl' o (time, 1, f) ks where- h (!w, !r, !s) u = let (w', r') = vm IntMap.! s IntMap.! u+ o (!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@@ -178,9 +177,9 @@ commodities.at t %= fmap (addconv (1/ratio) ?? f) commodities.at f %= fmap (addconv ratio ?? t) where- addconv r s t =+ addconv r s t' = let c = s^.commHistory- rm = case IntMap.lookup t c of+ 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
@@ -1,12 +1,34 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeFamilies #-} module Ledger.Commodity.Parse where -import "mtl" Control.Monad.State.Class-import Data.Text.Lazy-import Ledger.Balance-import Ledger.Commodity+import Control.Applicative+import Control.Lens+import "mtl" Control.Monad.State.Class+import qualified Data.IntMap.Strict as IntMap+import Data.Semigroup+import qualified Data.Text as T+import Data.Text.Lazy (Text, unpack)+--import qualified Data.Text.Lazy as TL+import Ledger.Balance+import Ledger.Commodity+--import Text.Parser.Char+--import Text.Parser.Combinators+import Text.Trifecta.Parser+import Text.Trifecta.Result -parseBalance :: MonadState CommodityMap m => Text -> m (Balance a)-parseBalance _str = undefined+parseBalance :: (MonadState CommodityMap m, Functor m, a ~ Rational)+ => Text -> m (Either BalanceError (Balance a))+parseBalance str =+ case parseString balanceParser mempty (unpack str) of+ Success (b, c) -> do+ len <- IntMap.size <$> use commodities+ commodities.at len .= Just c+ return . Right $ b+ Failure e ->+ return . Left $ BalanceParseError (T.pack (show e))++balanceParser :: a ~ Rational => Parser (Balance a, CommodityInfo)+balanceParser = undefined
Ledger/Commodity/Print.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} module Ledger.Commodity.Print ( printBalance@@ -10,41 +12,79 @@ import Control.Applicative import Control.Lens+import Control.Monad import "mtl" Control.Monad.Reader.Class import Control.Monad.Trans.Reader (runReader) import Control.Monad.Trans.State (evalState) import Control.Monad.Trans.Writer import qualified Data.IntMap.Strict as IntMap+import Data.List+import Data.List.Split import Data.Maybe (fromMaybe)-import Data.Text.Lazy+import Data.Number.CReal+import Data.Text.Lazy (Text, pack)+--import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Builder import Ledger.Balance import Ledger.Commodity import Ledger.Commodity.Parse -printBalance :: (MonadReader CommodityMap m, Functor m, Show a)+printBalance :: (MonadReader CommodityMap m, Functor m, a ~ Rational) => Balance a -> m Text-printBalance Zero = return "0"+printBalance Zero = return "0" printBalance (Plain x) = return $ pack (show x)-printBalance x = toLazyText <$> execWriterT (buildBalance x)+printBalance x = toLazyText <$> execWriterT (buildBalance x) -buildBalance :: (MonadReader CommodityMap m, Show a)+buildBalance :: (MonadReader CommodityMap m, Functor m, a ~ Rational) => Balance a -> WriterT Builder m () buildBalance (Amount c q) = do- mcomm <- view (commodities.at c)- let comm = fromMaybe defaultCommodityInfo mcomm- tell $ fromText (comm^.commSymbol)- tell $ fromString (show q)+ cm <- fromMaybe defaultCommodityInfo <$> view (commodities.at c) + unless (cm^.commSuffixed) $ do+ outputSymbol cm+ when (cm^.commSeparated) $+ tell $ fromLazyText " "++ tell $ fromString (formatAmount cm)++ when (cm^.commSuffixed) $ do+ when (cm^.commSeparated) $+ tell $ fromLazyText " "+ outputSymbol cm+ where+ outputSymbol cm = tell $ fromText (cm^.commSymbol)++ formatAmount cm =+ let prec = cm^.commPrecision+ str = showCReal prec (fromRational q)+ (n, m) = case break (== '.') str of+ (xs, '.':ys) -> (xs, ys)+ (xs, ys) -> (xs, ys)+ len = length m+ (com, per) = if cm^.commDecimalComma+ then (".", ",")+ else (",", ".")+ n' = if cm^.commThousands+ then reverse . intercalate com . chunksOf 3 . reverse $ n+ else n+ m' = if len < prec+ then m ++ replicate (prec - len) '0'+ else m+ in intercalate per [n', m']+ buildBalance (Balance xs) = mapM_ (buildBalance . uncurry Amount) $ IntMap.toList xs buildBalance _ = return () -balance :: Show a => CommodityMap -> Iso' (Balance a) Text-balance pool = iso toBalance fromBalance+balance :: a ~ Rational => CommodityMap -> Iso' (Balance a) Text+balance pool = iso fromBalance toBalance where- toBalance = flip runReader pool . printBalance- fromBalance = flip evalState pool . parseBalance+ toBalance str = flip evalState pool $ do+ eb <- parseBalance str+ return $ case eb of+ Left (_ :: BalanceError) -> Zero+ Right b -> b+ fromBalance = flip runReader pool . printBalance
Setup.hs view
commodities.cabal view
@@ -1,5 +1,5 @@ Name: commodities-Version: 0.2.0+Version: 0.2.0.1 Synopsis: Library for working with commoditized amounts and price histories Description: Library for working with commoditized amounts and price histories License-file: LICENSE@@ -25,20 +25,24 @@ Ledger.Commodity.Print build-depends: base >= 3 && < 5- , PSQueue+ , PSQueue >= 1.1 , comonad >= 4.0- , containers >= 0.4- , distributive >= 0.3- , keys >= 3.0.2+ , containers >= 0.5.0.0+ , distributive >= 0.3.2+ , failure >= 0.2+ , keys >= 3.10 , lens >= 3.10- , linear >= 0.7- , mtl- , numbers >= 2009.8.9- , semigroups+ , linear >= 1.3.1+ , mtl >= 2.1.2+ , numbers >= 3000.2.0.0+ , parsers >= 0.10.1.1+ , semigroups >= 0.12 , semigroupoids >= 4.0- , text >= 0.11.2- , thyme+ , split >= 0.2.2+ , text >= 0.11.3.1+ , thyme >= 0.3.1.0 , transformers+ , trifecta >= 1.2.1.1 test-suite doctests default-language: Haskell98@@ -48,9 +52,9 @@ hs-source-dirs: test build-depends: base >= 3 && < 5- , directory >= 1.0 && < 1.3- , doctest >= 0.8 && <= 0.10- , filepath >= 1.3 && < 1.4+ , directory >= 1.0 && < 1.4+ , doctest >= 0.8 && < 0.12+ , filepath >= 1.3 && < 1.5 Test-suite test default-language: Haskell98
test/Main.hs view
@@ -52,17 +52,17 @@ let oneHourAgo = addUTCTime (-3600) now oneDayAgo = addUTCTime (-(24 * 3600)) now - usd = (defaultPrimary "USD")+ usd = (defaultPrimaryCommodityInfo "USD") & commHistory .~ IntMap.fromList [ (2, Map.fromList [(oneHourAgo, 0.75)]) , (3, Map.fromList [(oneDayAgo, 0.66)]) ]- cad = (defaultPrimary "CAD")+ cad = (defaultPrimaryCommodityInfo "CAD") & commHistory .~ IntMap.fromList [ (1, Map.fromList [(oneHourAgo, 1.33)]) , (3, Map.fromList [(oneHourAgo, 0.83)]) ]- eur = (defaultPrimary "EUR")+ eur = (defaultPrimaryCommodityInfo "EUR") & commHistory .~ IntMap.fromList [ (1, Map.fromList [(oneDayAgo, 1.5)]) , (2, Map.fromList [(oneHourAgo, 1.2)])@@ -72,19 +72,12 @@ , (2, cad) , (3, eur) ]- where- defaultPrimary sym = defaultCommodityInfo- & commSymbol .~ sym- & commPrecision .~ 2- & commNoMarket .~ True- & commKnown .~ True- & commPrimary .~ True testMap' :: UTCTime -> CommodityMap testMap' now =- let usd = defaultPrimary "USD"- cad = defaultPrimary "CAD"- eur = defaultPrimary "EUR"+ let usd = defaultPrimaryCommodityInfo "USD"+ cad = defaultPrimaryCommodityInfo "CAD"+ eur = defaultPrimaryCommodityInfo "EUR" cm = CommodityMap $ IntMap.fromList [ (1, usd)@@ -97,10 +90,3 @@ addConversion 1 2 oneHourAgo (3 % 4) addConversion 1 3 oneDayAgo (2 % 3) addConversion 2 3 oneHourAgo (5 % 6)- where- defaultPrimary sym = defaultCommodityInfo- & commSymbol .~ sym- & commPrecision .~ 2- & commNoMarket .~ True- & commKnown .~ True- & commPrimary .~ True