diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Ledger/Balance.hs b/Ledger/Balance.hs new file mode 100644 --- /dev/null +++ b/Ledger/Balance.hs @@ -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 diff --git a/Ledger/Commodity.hs b/Ledger/Commodity.hs new file mode 100644 --- /dev/null +++ b/Ledger/Commodity.hs @@ -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 diff --git a/Ledger/Commodity/History.hs b/Ledger/Commodity/History.hs new file mode 100644 --- /dev/null +++ b/Ledger/Commodity/History.hs @@ -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 } diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/commodities.cabal b/commodities.cabal new file mode 100644 --- /dev/null +++ b/commodities.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + } diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -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