commodities (empty) → 0.0.1
raw patch · 8 files changed
+791/−0 lines, 8 filesdep +PSQueuedep +QuickCheckdep +basesetup-changed
Dependencies added: PSQueue, QuickCheck, base, commodities, comonad-transformers, containers, directory, distributive, doctest, filepath, hspec, hspec-expectations, keys, lens, linear, numbers, representable-functors, semigroupoids, semigroups, text, thyme, transformers
Files
- LICENSE +19/−0
- Ledger/Balance.hs +299/−0
- Ledger/Commodity.hs +74/−0
- Ledger/Commodity/History.hs +188/−0
- Setup.hs +2/−0
- commodities.cabal +69/−0
- test/Main.hs +111/−0
- test/doctests.hs +29/−0
+ LICENSE view
@@ -0,0 +1,19 @@+opyright (c) 2012 John Wiegley++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Ledger/Balance.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Ledger.Balance+ ( Balance(..)+ , noCommodity+ , balanceSum+ , insert+ , delete+ , balanceStore+ ) where++import Control.Applicative+import Control.Comonad.Trans.Store+import Control.Lens hiding (from, to)+import qualified Control.Lens.Internal as Lens+import Control.Monad hiding (forM)+import Data.Data+import Data.Foldable as Foldable+import Data.Functor.Bind+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import qualified Data.Key as K+import Data.Semigroup+import Data.Traversable+import Ledger.Commodity+import Linear.Vector+import Prelude hiding (lookup)++noCommodity :: Commodity+noCommodity = 0++-- | A value representing either zero (all zeroes are equivalent), a+-- commoditized value, or a vector space of values indexed by commodity.+data Balance a = Zero+ | Plain a -- ^ An uncommoditized integer+ | Amount Commodity a -- ^ A single commoditized amount+ | Balance (IntMap a) -- ^ A vector-space over commodities+ deriving (Eq, Ord, Show, Read, Typeable, Data)++non' :: a -> Iso' (Maybe a) a+non' = flip anon (const False)++-- instance Num a => Num (Balance a) where+-- x + y = x ^+^ y++-- _ * Zero = Zero+-- Zero * _ = Zero+-- x * Plain q = x ^* q+-- Plain q * y = y ^* q+-- x * Amount _ q = x ^* q+-- Amount _ q * y = y ^* q+-- Balance _ * Balance _ = error "Cannot multiply two balances"++-- x - y = x ^-^ y+-- negate = negated+-- abs x = abs <$> x+-- signum = error "signum not supported on Balance values"+-- fromInteger = Plain . fromInteger++instance Additive Balance where+ zero = Zero++ Zero ^+^ x = x+ x ^+^ Zero = x++ Plain qx ^+^ Plain qy = Plain (qx + qy)+ Plain qx ^+^ Amount cy qy = Amount cy (qx + qy)+ Amount cx qx ^+^ Plain qy = Amount cx (qx + qy)+ Plain qx ^+^ y@(Balance _) = Amount noCommodity qx ^+^ y+ x@(Balance _) ^+^ Plain qy = x ^+^ Amount noCommodity qy++ 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++ Balance xs ^+^ Balance ys = Balance $ xs ^+^ ys+ {-# INLINE (^+^) #-}++ Balance xs ^-^ Balance ys = Balance $ xs ^-^ ys++ Zero ^-^ x = fmap negate x+ x ^-^ Zero = x+ x ^-^ y = x ^+^ (Zero ^-^ y)+ {-# INLINE (^-^) #-}++instance Functor Balance where+ fmap _ Zero = Zero+ fmap f (Plain x) = Plain (f x)+ fmap f (Amount c x) = Amount c (f x)+ fmap f (Balance xs) = Balance $ fmap f xs++instance Applicative Balance where+ pure = Plain++ Zero <*> _ = Zero+ _ <*> Zero = Zero++ Plain f <*> Plain qy = Plain (f qy)+ Plain f <*> Amount cy qy = Amount cy (f qy)+ Amount cx f <*> Plain qy = Amount cx (f qy)+ Plain f <*> Balance xs = Balance $ fmap f xs+ Balance fs <*> Plain qy = Balance $ fmap ($ qy) fs++ Amount cx f <*> Amount cy qy+ | cx == cy = Amount cy (f qy)+ | otherwise = Zero++ Amount cx f <*> Balance xs =+ maybe Zero (Amount cx . f) $ IntMap.lookup cx xs+ Balance fs <*> Amount cy qy =+ maybe Zero (\f -> Amount cy (f qy)) $ IntMap.lookup cy fs++ Balance fs <*> Balance ys =+ Balance $ IntMap.intersectionWith ($) fs ys++instance Apply Balance where+ (<.>) = (<*>)++instance Bind Balance where+ Zero >>- _ = Zero+ Plain q >>- f = f q++ Amount c q >>- f = case f q of+ Zero -> Zero+ Plain _ -> Zero+ amt@(Amount c' _)+ | c == c' -> amt+ | otherwise -> Zero+ Balance xs -> case IntMap.lookup c xs of+ Nothing -> Zero+ Just v -> Amount c v++ Balance xs >>- f =+ Balance $ IntMap.foldlWithKey' go IntMap.empty xs+ where+ go m c a = case f a of+ Zero -> m+ Plain _ -> m+ Amount c' q'+ | c == c' -> IntMap.insert c q' m+ | otherwise -> m+ Balance xs' -> case IntMap.lookup c xs' of+ Nothing -> m+ Just v -> IntMap.insert c v m++instance Monad Balance where+ return = Plain+ (>>=) = (>>-)++type instance K.Key Balance = IntMap.Key++instance K.Lookup Balance where+ lookup _ Zero = Nothing+ lookup _ (Plain _) = Nothing+ lookup k (Amount c x) = if k == c then Just x else Nothing+ lookup k (Balance xs) = IntMap.lookup k xs++insert :: Int -> a -> Balance a -> Balance a+insert k q Zero = Amount k q+insert k q (Plain q') =+ Balance $ IntMap.fromList [ (noCommodity, q'), (k, q) ]+insert k q (Amount c q') =+ Balance $ IntMap.fromList [ (c, q'), (k, q) ]+insert k q (Balance xs) = Balance $ IntMap.insert k q xs++delete :: Int -> Balance a -> Balance a+delete _k Zero = Zero+delete _k pl@(Plain _) = pl+delete k amt@(Amount c _)+ | k == c = Zero+ | otherwise = amt+delete k (Balance xs) = Balance (IntMap.delete k xs)++instance K.Indexable Balance where+ index Zero _ = error "Key not in zero Balance"+ index (Plain _) _ = error "Key not in plain Balance"+ index (Amount c x) k = if c == k+ then x+ else error "Key not in zero Balance"+ index (Balance xs) k = K.index xs k++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 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 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+ {-# INLINE imap #-}++instance FoldableWithIndex Int Balance where+ ifoldMap = ifoldMapOf itraversed+ {-# INLINE ifoldMap #-}++instance TraversableWithIndex Int Balance where+ itraverse = itraverseOf traversed+ {-# INLINE itraverse #-}++instance K.Adjustable Balance where+ adjust _ _ Zero = Zero+ adjust f _ (Plain q) = Plain (f q)+ adjust f _ (Amount c q) = Amount c (f q)+ adjust f k (Balance xs) = Balance (IntMap.adjust f k xs)++instance Foldable Balance where+ foldMap _ Zero = mempty+ foldMap f (Plain x) = f x+ foldMap f (Amount _ x) = f x+ foldMap f (Balance xs) = foldMap f xs++ foldr _ z Zero = z+ foldr f z (Plain x) = f x z+ foldr f z (Amount _ x) = f x z+ foldr f z (Balance xs) = Foldable.foldr f z xs++instance Traversable Balance where+ traverse _ Zero = pure Zero+ traverse f (Plain x) = fmap Plain (f x)+ traverse f (Amount c x) = fmap (Amount c) (f x)+ traverse f (Balance xs) = fmap Balance (traverse f xs)++ sequenceA Zero = pure Zero+ sequenceA (Plain q) = fmap Plain q+ sequenceA (Amount c x) = fmap (Amount c) x+ sequenceA (Balance xs) = fmap Balance (sequenceA xs)++instance Num a => Semigroup (Balance a) where+ Zero <> x = x+ y <> Zero = y++ Plain qx <> Plain qy = Plain $ qx + qy+ Plain qx <> Amount cy qy = Amount cy (qx + qy)+ Amount cx qx <> Plain qy = Amount cx (qx + qy)+ Plain qx <> y = Amount noCommodity qx `mappend` y+ x <> Plain qy = x `mappend` Amount noCommodity qy++ 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 (IntMap.singleton cx qx <> ys)+ Balance xs <> Amount cy qy = Balance (xs <> IntMap.singleton cy qy)++ Balance xs <> Balance ys = Balance (xs <> ys)++instance Num a => Monoid (Balance a) where+ mempty = Zero+ mappend x y = x <> y++class Monoid g => Group g where+ inverse :: g -> g++instance Num a => Group (Balance a) where+ inverse x = Zero ^-^ x++balanceStore :: K.Indexable f => K.Key f -> f a -> Store (K.Key f) a+balanceStore k x = store (K.index x) k++balanceSum :: Num a => [Balance a] -> Balance a+balanceSum = Foldable.foldr (^+^) Zero
+ Ledger/Commodity.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Ledger.Commodity+ ( Commodity+ , CommodityInfo(..)+ , defaultCommodityInfo+ , CommodityMap(..)+ ) where++import Data.IntMap (IntMap, Key)+import qualified Data.IntMap as IntMap+import Data.Map (Map)+import Data.Ratio+import Data.Semigroup+import Data.Text (Text)+import Data.Thyme.Time+import Prelude hiding (lookup)++-- | Commodities are simply indices into a commodity info map, which relates+-- such commodities to the information known about them.+type Commodity = Key++-- | 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))+ } deriving (Eq, Read, Show)++-- | 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+ }++-- | A commodities map, relating commodity indices to information about+-- those commodities.+data CommodityMap = CommodityMap+ { commodities :: IntMap CommodityInfo+ }+ deriving (Eq, Read, Show)++instance Semigroup CommodityMap where+ CommodityMap x <> CommodityMap y = CommodityMap (x <> y)++instance Monoid CommodityMap where+ mempty = CommodityMap mempty+ x `mappend` y = x <> y
+ Ledger/Commodity/History.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++module Ledger.Commodity.History+ ( findConversion+ , addConversion+ , intAStar+ , intAStarM+ ) where++import Control.Applicative+import Control.Monad hiding (forM)+import Control.Monad.Trans.State+import Data.Functor.Identity+import Data.IntMap (IntMap, Key)+import qualified Data.IntMap as IntMap+import Data.List (foldl')+import qualified Data.Map as Map+import Data.PSQueue (PSQ, Binding(..), minView)+import qualified Data.PSQueue as PSQ+import Data.Ratio+import Data.Thyme.Time+import Data.Traversable+import Ledger.Commodity+import Prelude hiding (lookup)++-- | The following A* algorithm was written by Cale Gibbard, and modified here+-- to apply to IntMap's instead of general Map's.+data IntAStar c = IntAStar+ { visited :: !(IntMap c)+ , waiting :: !(PSQ Key c)+ , score :: !(IntMap c)+ , memoHeur :: !(IntMap c)+ , cameFrom :: !(IntMap Key)+ , end :: !(Maybe Key)+ } deriving Show++intAStarInit :: (Num c, Ord c) => Key -> IntAStar c+intAStarInit start = IntAStar+ { visited = IntMap.empty+ , waiting = PSQ.singleton start 0+ , score = IntMap.singleton start 0+ , memoHeur = IntMap.empty+ , cameFrom = IntMap.empty+ , end = Nothing+ }++runIntAStarM :: (Monad m, Ord c, Num c)+ => (Key -> m (IntMap c)) -- adjacencies in graph+ -> (Key -> m c) -- heuristic distance to goal+ -> (Key -> m Bool) -- goal+ -> Key -- starting vertex+ -> m (IntAStar c) -- final state+runIntAStarM graph heur goal start = aStar' (intAStarInit start)+ where+ aStar' s = case minView (waiting s) of+ Nothing -> return s+ Just (x :-> d, w') -> do+ g <- goal x+ if g+ then return (s { end = Just x })+ else do+ ns <- graph x+ u <- foldM (expand x)+ (s { waiting = w'+ , visited = IntMap.insert x d (visited s)+ })+ (IntMap.toList (ns IntMap.\\ visited s))+ aStar' u++ expand x s (y,d) = do+ let v = score s IntMap.! x + d+ case PSQ.lookup y (waiting s) of+ Nothing -> do+ h <- heur y+ return $ link x y v+ (s { memoHeur = IntMap.insert y h (memoHeur s) })+ Just _ -> return $ if v < score s IntMap.! y+ then link x y v s+ else s+ link x y v s+ = s { cameFrom = IntMap.insert y x (cameFrom s),+ score = IntMap.insert y v (score s),+ waiting = PSQ.insert y (v + memoHeur s IntMap.! y) (waiting s) }++-- | This function computes an optimal (minimal distance) path through a graph+-- in a best-first fashion, starting from a given starting point.+intAStarM+ :: (Monad m, Ord c, Num c)+ => (Key -> m (IntMap c)) -- ^ The graph we are searching through, given as+ -- a function from vertices to their neighbours.+ -> (Key -> m c) -- ^ Heuristic distance to the (nearest) goal.+ -- This should never overestimate the distance,+ -- or else the path found may not be minimal.+ -> (Key -> m Bool) -- ^ The goal, specified as a boolean predicate+ -- on vertices.+ -> m Key -- ^ The vertex to start searching from.+ -> m (Maybe [Key]) -- ^ An optimal path, if any path exists. This+ -- excludes the starting vertex.+intAStarM graph heur goal start = do+ sv <- start+ s <- runIntAStarM graph heur goal sv+ forM (end s) $ \e ->+ return . reverse+ . takeWhile (not . (== sv))+ . iterate (cameFrom s IntMap.!)+ $ e++-- | This function computes an optimal (minimal distance) path through a graph+-- in a best-first fashion, starting from a given starting point.+intAStar :: (Ord c, Num c)+ => (Key -> IntMap c) -- ^ The graph we are searching through, given as+ -- a function from vertices to their neighbours.+ -> (Key -> c) -- ^ Heuristic distance to the (nearest) goal.+ -- This should never overestimate the distance, or+ -- else the path found may not be minimal.+ -> (Key -> Bool) -- ^ The goal, specified as a boolean predicate on+ -- vertices.+ -> Key -- ^ The vertex to start searching from.+ -> Maybe [Key] -- ^ An optimal path, if any path exists. This+ -- excludes the starting vertex.+intAStar graph heur goal start =+ runIdentity $ intAStarM+ (return . graph)+ (return . heur)+ (return . goal)+ (return start)++-- | Lookup a price conversion from the source commodity to the target, using+-- data from the given time or earlier. Result is Nothing if no conversion+-- can be found, or else the best conversion ratio plus the time of the+-- oldest link.+findConversion :: Commodity -- ^ Source commodity+ -> Commodity -- ^ Target commodity+ -> UTCTime -- ^ Look for conversions on or before this+ -> CommodityMap -- ^ Set of commodities to search+ -> Maybe (UTCTime, Rational)+findConversion from to time cm =+ let (keyPath, valuesMap) =+ flip runState IntMap.empty $+ intAStarM g h (return . (== to)) (return from)+ in go valuesMap <$> keyPath+ where+ g c = do+ vm <- get+ let (!m, !sm) = IntMap.foldlWithKey'+ (\(!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'))+ (IntMap.empty, IntMap.empty)+ (commHistory $ commodities cm IntMap.! c)+ 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+ where+ f (!w, !r, !s) t = let (w', r') = vm IntMap.! s IntMap.! t+ in (min w w', r / r', t)++-- | 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+ 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+ Nothing -> Map.singleton time r+ Just m -> Map.insert time r m+ in s { commHistory = IntMap.insert t rm c }
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ commodities.cabal view
@@ -0,0 +1,69 @@+Name: commodities+Version: 0.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+License: BSD3+Author: John Wiegley+Maintainer: johnw@newartisans.com+Build-Type: Simple+Cabal-Version: >= 1.10+Category: Finance++source-repository head+ type: git+ location: git://github.com/ledger/ledger4.git++library+ default-language: Haskell98+ ghc-options: -Wall+ exposed-modules:+ Ledger.Balance+ Ledger.Commodity+ Ledger.Commodity.History+ build-depends:+ base >= 3 && < 5+ , PSQueue+ , comonad-transformers >= 3.0.1+ , containers >= 0.4+ , distributive >= 0.3+ , keys >= 3.0.2+ , lens >= 3.7+ , linear >= 0.7+ , numbers >= 2009.8.9+ , representable-functors >= 3.0.1+ , semigroups+ , semigroupoids >= 3.0.2+ , text >= 0.11.2+ , thyme+ , transformers++test-suite doctests+ default-language: Haskell98+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ ghc-options: -Wall+ hs-source-dirs: test+ build-depends:+ base >= 3 && < 5+ , directory >= 1.0 && < 1.3+ , doctest >= 0.8 && <= 0.10+ , filepath >= 1.3 && < 1.4++Test-suite test+ default-language: Haskell98+ type: exitcode-stdio-1.0+ main-is: Main.hs+ ghc-options: -Wall+ hs-source-dirs: test+ build-depends: + base >= 3 && < 5+ , commodities+ , QuickCheck+ , hspec+ , hspec-expectations+ , containers+ , lens+ , semigroups+ , thyme+ , transformers
+ test/Main.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Exception+import Control.Lens+import Control.Monad.Trans.State+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import Data.Ratio+import Data.Thyme+import Data.Thyme.Time+import Ledger.Commodity+import Ledger.Commodity.History+import Test.Hspec+import Test.QuickCheck++main :: IO ()+main = hspec $ do+ describe "Sample tests" $ do+ it "returns the first element of a list" $+ head [23 ..] `shouldBe` (23 :: Int)++ it "returns the first element of an *arbitrary* list" $+ property $ \x xs -> head (x:xs) == (x :: Int)++ it "throws an exception if used with an empty list" $+ evaluate (head []) `shouldThrow` anyException++ describe "Ledger.Commodity.History" $ do+ it "works with testMap" $ do+ let cm = testMap moment+ findConversion 1 3 moment cm+ `shouldBe` Just (oneHourAgo, 400 % 249)+ findConversion 1 3 (addUTCTime (-7000) moment) cm+ `shouldBe` Just (oneDayAgo, 50 % 33)++ it "works with testMap'" $ do+ let cm' = testMap' moment+ findConversion 1 3 moment cm'+ `shouldBe` Just (oneHourAgo, 8 % 5)+ findConversion 1 3 (addUTCTime (-7000) moment) cm'+ `shouldBe` Just (oneDayAgo, 3 % 2)+ where+ moment = UTCTime (ModifiedJulianDay 50000) (secondsToDiffTime 0)+ ^. from utcTime+ oneHourAgo = addUTCTime (-3600) moment+ oneDayAgo = addUTCTime (-(24 * 3600)) moment++testMap :: UTCTime -> CommodityMap+testMap now =+ let oneHourAgo = addUTCTime (-3600) now+ oneDayAgo = addUTCTime (-(24 * 3600)) now++ usd = (defaultPrimary "USD")+ { commHistory =+ IntMap.fromList [ (2, Map.fromList [(oneHourAgo, 0.75)])+ , (3, Map.fromList [(oneDayAgo, 0.66)])+ ]+ }+ cad = (defaultPrimary "CAD")+ { commHistory =+ IntMap.fromList [ (1, Map.fromList [(oneHourAgo, 1.33)])+ , (3, Map.fromList [(oneHourAgo, 0.83)])+ ]+ }+ eur = (defaultPrimary "EUR")+ { commHistory =+ IntMap.fromList [ (1, Map.fromList [(oneDayAgo, 1.5)])+ , (2, Map.fromList [(oneHourAgo, 1.2)])+ ]+ }+ in CommodityMap $ IntMap.fromList+ [ (1, usd)+ , (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"++ cm = CommodityMap $ IntMap.fromList+ [ (1, usd)+ , (2, cad)+ , (3, eur)+ ]+ in flip execState cm $ do+ let oneHourAgo = addUTCTime (-3600) now+ oneDayAgo = addUTCTime (-(24 * 3600)) now+ 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+ }
+ test/doctests.hs view
@@ -0,0 +1,29 @@+module Main where++import Test.DocTest+import System.Directory+import System.FilePath+import Control.Applicative+import Control.Monad+import Data.List++main :: IO ()+main = getSources >>= \sources -> doctest $+ "-i."+ : "-idist/build/autogen"+ : "-optP-include"+ : "-optPdist/build/autogen/cabal_macros.h"+ : sources++getSources :: IO [FilePath]+getSources = filter (\x -> ".hs" `isSuffixOf` x) <$> go "src"+ where+ go dir = do+ (dirs, files) <- getFilesAndDirectories dir+ (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+ c <- map (dir </>) . filter (`notElem` ["..", "."])+ <$> getDirectoryContents dir+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c