├── .dir-locals.el ├── .gitignore ├── LICENSE ├── README.md ├── commodities ├── LICENSE ├── Ledger │ ├── Balance.hs │ ├── Commodity.hs │ └── Commodity │ │ ├── History.hs │ │ ├── Parse.hs │ │ └── Print.hs ├── Setup.hs ├── TAGS ├── commodities.cabal ├── default.nix └── test │ ├── Main.hs │ └── doctests.hs ├── ledger-expr ├── Ledger │ └── Expr.hs ├── doc │ └── LICENSE ├── ledger-expr.cabal └── test │ └── doctests.hs ├── ledger-parse ├── .gitignore ├── Ledger │ └── Parser │ │ └── Text.hs ├── doc │ └── LICENSE ├── ledger-parse.cabal └── test │ ├── doctests.hs │ └── testAmount.hs └── sources.txt /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ((nil . ((nix-package-name . "pkgs.haskellPackages_ghc782.newartisans")))) 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | /commodities/Setup 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, John Wiegley 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | * Neither the name of ledger4 nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This was a personal experiment with using Haskell for ledger by @jwiegley, who may come back to it someday in the future, just out of interest. 2 | 3 | A similar project is at 4 | -------------------------------------------------------------------------------- /commodities/LICENSE: -------------------------------------------------------------------------------- 1 | opyright (c) 2012 John Wiegley 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /commodities/Ledger/Balance.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE PackageImports #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | 14 | {-# OPTIONS_GHC -fno-warn-orphans #-} 15 | 16 | module Ledger.Balance 17 | ( Balance(..) 18 | , noCommodity 19 | , balanceSum 20 | , insert 21 | , delete 22 | , balanceStore 23 | , BalanceError(..) 24 | ) where 25 | 26 | import Control.Applicative 27 | import "comonad" Control.Comonad.Trans.Store 28 | import Control.Exception 29 | import Control.Lens hiding (from, to) 30 | import qualified Control.Lens.Internal as Lens 31 | import Control.Monad hiding (forM) 32 | import Data.Data 33 | import Data.Foldable as Foldable 34 | import Data.Functor.Bind 35 | import Data.IntMap (IntMap) 36 | import qualified Data.IntMap as IntMap 37 | import qualified Data.Key as K 38 | import Data.Semigroup 39 | import Data.Text (Text) 40 | import Data.Traversable 41 | import Ledger.Commodity 42 | import Linear.Vector 43 | import Prelude hiding (lookup) 44 | 45 | noCommodity :: Commodity 46 | noCommodity = 0 47 | 48 | -- | A value representing either zero (all zeroes are equivalent), a 49 | -- commoditized value, or a vector space of values indexed by commodity. 50 | data Balance a = Zero 51 | | Plain a -- ^ An uncommoditized integer 52 | | Amount Commodity a -- ^ A single commoditized amount 53 | | Balance (IntMap a) -- ^ A vector-space over commodities 54 | deriving (Eq, Ord, Show, Read, Typeable, Data) 55 | 56 | makePrisms ''Balance 57 | 58 | non'' :: a -> Iso' (Maybe a) a 59 | non'' = flip anon (const False) 60 | 61 | -- instance Num a => Num (Balance a) where 62 | -- x + y = x ^+^ y 63 | 64 | -- _ * Zero = Zero 65 | -- Zero * _ = Zero 66 | -- x * Plain q = x ^* q 67 | -- Plain q * y = y ^* q 68 | -- x * Amount _ q = x ^* q 69 | -- Amount _ q * y = y ^* q 70 | -- Balance _ * Balance _ = error "Cannot multiply two balances" 71 | 72 | -- x - y = x ^-^ y 73 | -- negate = negated 74 | -- abs x = abs <$> x 75 | -- signum = error "signum not supported on Balance values" 76 | -- fromInteger = Plain . fromInteger 77 | 78 | instance Additive Balance where 79 | zero = Zero 80 | 81 | Zero ^+^ x = x 82 | x ^+^ Zero = x 83 | 84 | Plain qx ^+^ Plain qy = Plain (qx + qy) 85 | Plain qx ^+^ Amount cy qy = Amount cy (qx + qy) 86 | Amount cx qx ^+^ Plain qy = Amount cx (qx + qy) 87 | Plain qx ^+^ y@(Balance _) = Amount noCommodity qx ^+^ y 88 | x@(Balance _) ^+^ Plain qy = x ^+^ Amount noCommodity qy 89 | 90 | Amount cx qx ^+^ Amount cy qy 91 | | cx == cy = Amount cx (qx + qy) 92 | | otherwise = Balance $ IntMap.fromList [(cx,qx), (cy,qy)] 93 | Amount cx qx ^+^ Balance ys = Balance $ ys & at cx.non'' 0 +~ qx 94 | Balance xs ^+^ Amount cy qy = Balance $ xs & at cy.non'' 0 +~ qy 95 | 96 | Balance xs ^+^ Balance ys = Balance $ xs ^+^ ys 97 | {-# INLINE (^+^) #-} 98 | 99 | Balance xs ^-^ Balance ys = Balance $ xs ^-^ ys 100 | 101 | Zero ^-^ x = fmap negate x 102 | x ^-^ Zero = x 103 | x ^-^ y = x ^+^ (Zero ^-^ y) 104 | {-# INLINE (^-^) #-} 105 | 106 | instance Functor Balance where 107 | fmap _ Zero = Zero 108 | fmap f (Plain x) = Plain (f x) 109 | fmap f (Amount c x) = Amount c (f x) 110 | fmap f (Balance xs) = Balance $ fmap f xs 111 | 112 | instance Applicative Balance where 113 | pure = Plain 114 | 115 | Zero <*> _ = Zero 116 | _ <*> Zero = Zero 117 | 118 | Plain f <*> Plain qy = Plain (f qy) 119 | Plain f <*> Amount cy qy = Amount cy (f qy) 120 | Amount cx f <*> Plain qy = Amount cx (f qy) 121 | Plain f <*> Balance xs = Balance $ fmap f xs 122 | Balance fs <*> Plain qy = Balance $ fmap ($ qy) fs 123 | 124 | Amount cx f <*> Amount cy qy 125 | | cx == cy = Amount cy (f qy) 126 | | otherwise = Zero 127 | 128 | Amount cx f <*> Balance xs = 129 | maybe Zero (Amount cx . f) $ IntMap.lookup cx xs 130 | Balance fs <*> Amount cy qy = 131 | maybe Zero (\f -> Amount cy (f qy)) $ IntMap.lookup cy fs 132 | 133 | Balance fs <*> Balance ys = 134 | Balance $ IntMap.intersectionWith ($) fs ys 135 | 136 | instance Apply Balance where 137 | (<.>) = (<*>) 138 | 139 | instance Bind Balance where 140 | Zero >>- _ = Zero 141 | Plain q >>- f = f q 142 | 143 | Amount c q >>- f = case f q of 144 | Zero -> Zero 145 | Plain _ -> Zero 146 | amt@(Amount c' _) 147 | | c == c' -> amt 148 | | otherwise -> Zero 149 | Balance xs -> case IntMap.lookup c xs of 150 | Nothing -> Zero 151 | Just v -> Amount c v 152 | 153 | Balance xs >>- f = 154 | Balance $ IntMap.foldlWithKey' go IntMap.empty xs 155 | where 156 | go m c a = case f a of 157 | Zero -> m 158 | Plain _ -> m 159 | Amount c' q' 160 | | c == c' -> IntMap.insert c q' m 161 | | otherwise -> m 162 | Balance xs' -> case IntMap.lookup c xs' of 163 | Nothing -> m 164 | Just v -> IntMap.insert c v m 165 | 166 | instance Monad Balance where 167 | return = Plain 168 | (>>=) = (>>-) 169 | 170 | type instance K.Key Balance = IntMap.Key 171 | 172 | instance K.Lookup Balance where 173 | lookup _ Zero = Nothing 174 | lookup _ (Plain _) = Nothing 175 | lookup k (Amount c x) = if k == c then Just x else Nothing 176 | lookup k (Balance xs) = IntMap.lookup k xs 177 | 178 | insert :: Int -> a -> Balance a -> Balance a 179 | insert k q Zero = Amount k q 180 | insert k q (Plain q') = 181 | Balance $ IntMap.fromList [ (noCommodity, q'), (k, q) ] 182 | insert k q (Amount c q') = 183 | Balance $ IntMap.fromList [ (c, q'), (k, q) ] 184 | insert k q (Balance xs) = Balance $ IntMap.insert k q xs 185 | 186 | delete :: Int -> Balance a -> Balance a 187 | delete _k Zero = Zero 188 | delete _k pl@(Plain _) = pl 189 | delete k amt@(Amount c _) 190 | | k == c = Zero 191 | | otherwise = amt 192 | delete k (Balance xs) = Balance (IntMap.delete k xs) 193 | 194 | instance K.Indexable Balance where 195 | index Zero _ = error "Key not in zero Balance" 196 | index (Plain _) _ = error "Key not in plain Balance" 197 | index (Amount c x) k = if c == k 198 | then x 199 | else error "Key not in zero Balance" 200 | index (Balance xs) k = K.index xs k 201 | 202 | type instance Index (Balance a) = Int 203 | type instance IxValue (Balance a) = a 204 | -- instance Applicative f => Ixed f (Balance a) where 205 | -- ix _k _f Zero = pure Zero 206 | -- ix _k _f pl@(Plain _) = pure pl 207 | -- ix k f amt@(Amount c q) 208 | -- | k == c = Amount c <$> (Lens.indexed f k q <&> id) 209 | -- | otherwise = pure amt 210 | -- ix k f bal@(Balance xs) = case IntMap.lookup k xs of 211 | -- Just v -> Balance 212 | -- <$> (Lens.indexed f k v <&> \v' -> IntMap.insert k v' xs) 213 | -- Nothing -> pure bal 214 | 215 | -- instance At (Balance a) where 216 | -- at k f m = Lens.indexed f k mv <&> \r -> case r of 217 | -- Nothing -> maybe m (const (delete k m)) mv 218 | -- Just v' -> insert k v' m 219 | -- where mv = K.lookup k m 220 | 221 | -- instance (Contravariant f, Functor f) => Contains f (Balance a) where 222 | -- contains = containsLookup K.lookup 223 | -- {-# INLINE contains #-} 224 | 225 | -- instance Applicative f => Each f (Balance a) (Balance b) a b where 226 | -- each _ Zero = pure Zero 227 | -- each f (Plain q) = Plain <$> Lens.indexed f noCommodity q 228 | -- each f (Amount c q) = Amount c <$> Lens.indexed f c q 229 | -- each f (Balance m) = sequenceA $ Balance $ IntMap.mapWithKey f' m 230 | -- where f' = Lens.indexed f 231 | -- {-# INLINE each #-} 232 | 233 | instance FunctorWithIndex Int Balance where 234 | imap = iover itraversed 235 | {-# INLINE imap #-} 236 | 237 | instance FoldableWithIndex Int Balance where 238 | ifoldMap = ifoldMapOf itraversed 239 | {-# INLINE ifoldMap #-} 240 | 241 | instance TraversableWithIndex Int Balance where 242 | itraverse = itraverseOf traversed 243 | {-# INLINE itraverse #-} 244 | 245 | instance K.Adjustable Balance where 246 | adjust _ _ Zero = Zero 247 | adjust f _ (Plain q) = Plain (f q) 248 | adjust f _ (Amount c q) = Amount c (f q) 249 | adjust f k (Balance xs) = Balance (IntMap.adjust f k xs) 250 | 251 | instance Foldable Balance where 252 | foldMap _ Zero = mempty 253 | foldMap f (Plain x) = f x 254 | foldMap f (Amount _ x) = f x 255 | foldMap f (Balance xs) = foldMap f xs 256 | 257 | foldr _ z Zero = z 258 | foldr f z (Plain x) = f x z 259 | foldr f z (Amount _ x) = f x z 260 | foldr f z (Balance xs) = Foldable.foldr f z xs 261 | 262 | instance Traversable Balance where 263 | traverse _ Zero = pure Zero 264 | traverse f (Plain x) = fmap Plain (f x) 265 | traverse f (Amount c x) = fmap (Amount c) (f x) 266 | traverse f (Balance xs) = fmap Balance (traverse f xs) 267 | 268 | sequenceA Zero = pure Zero 269 | sequenceA (Plain q) = fmap Plain q 270 | sequenceA (Amount c x) = fmap (Amount c) x 271 | sequenceA (Balance xs) = fmap Balance (sequenceA xs) 272 | 273 | instance Num a => Semigroup (Balance a) where 274 | Zero <> x = x 275 | y <> Zero = y 276 | 277 | Plain qx <> Plain qy = Plain $ qx + qy 278 | Plain qx <> Amount cy qy = Amount cy (qx + qy) 279 | Amount cx qx <> Plain qy = Amount cx (qx + qy) 280 | Plain qx <> y = Amount noCommodity qx `mappend` y 281 | x <> Plain qy = x `mappend` Amount noCommodity qy 282 | 283 | Amount cx qx <> Amount cy qy 284 | | cx == cy = Amount cx (qx + qy) 285 | | otherwise = Balance (IntMap.fromList [(cx,qx),(cy,qy)]) 286 | 287 | Amount cx qx <> Balance ys = Balance (IntMap.singleton cx qx <> ys) 288 | Balance xs <> Amount cy qy = Balance (xs <> IntMap.singleton cy qy) 289 | 290 | Balance xs <> Balance ys = Balance (xs <> ys) 291 | 292 | instance Num a => Monoid (Balance a) where 293 | mempty = Zero 294 | mappend x y = x <> y 295 | 296 | class Monoid g => Group g where 297 | inverse :: g -> g 298 | 299 | instance Num a => Group (Balance a) where 300 | inverse x = Zero ^-^ x 301 | 302 | balanceStore :: K.Indexable f => K.Key f -> f a -> Store (K.Key f) a 303 | balanceStore k x = store (K.index x) k 304 | 305 | balanceSum :: Num a => [Balance a] -> Balance a 306 | balanceSum = Foldable.foldr (^+^) Zero 307 | 308 | data BalanceError = BalanceParseError Text 309 | deriving (Show, Typeable) 310 | 311 | instance Exception BalanceError 312 | -------------------------------------------------------------------------------- /commodities/Ledger/Commodity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Ledger.Commodity 11 | ( Commodity 12 | , CommodityInfo(..), HasCommodityInfo(..) 13 | , defaultCommodityInfo, defaultPrimaryCommodityInfo 14 | , CommodityMap(..), HasCommodityMap(..) 15 | , extendByDigits 16 | ) where 17 | 18 | import Control.Lens 19 | import Data.IntMap (IntMap, Key) 20 | import qualified Data.IntMap as IntMap 21 | import Data.Map (Map) 22 | import Data.Ratio 23 | import Data.Semigroup 24 | import Data.Text (Text) 25 | import Data.Thyme.Time 26 | import Prelude hiding (lookup) 27 | 28 | -- | Commodities are simply indices into a commodity info map, which relates 29 | -- such commodities to the information known about them. 30 | type Commodity = Key 31 | 32 | extendByDigits :: Int 33 | extendByDigits = 6 34 | 35 | -- | All of the information known about a commodity. 36 | data CommodityInfo = CommodityInfo 37 | { _commSymbol :: !Text 38 | , _commPrecision :: !Int 39 | , _commSuffixed :: !Bool 40 | , _commSeparated :: !Bool 41 | , _commThousands :: !Bool 42 | , _commDecimalComma :: !Bool 43 | , _commNoMarket :: !Bool 44 | , _commBuiltin :: !Bool 45 | , _commKnown :: !Bool 46 | , _commPrimary :: !Bool 47 | , _commHistory :: !(IntMap (Map UTCTime Rational)) 48 | } deriving (Eq, Read, Show) 49 | 50 | makeClassy ''CommodityInfo 51 | 52 | instance Semigroup CommodityInfo where 53 | x <> y = x 54 | & commSymbol .~ y^.commSymbol 55 | & commPrecision .~ max (x^.commPrecision) (y^.commPrecision) 56 | & commSuffixed .~ (x^.commSuffixed || y^.commSuffixed) 57 | & commSeparated .~ (x^.commSeparated || y^.commSeparated) 58 | & commThousands .~ (x^.commThousands || y^.commThousands) 59 | & commDecimalComma .~ (x^.commDecimalComma || y^.commDecimalComma) 60 | & commNoMarket .~ (x^.commNoMarket || y^.commNoMarket) 61 | & commBuiltin .~ (x^.commBuiltin || y^.commBuiltin) 62 | & commKnown .~ (x^.commKnown || y^.commKnown) 63 | & commPrimary .~ (x^.commPrimary || y^.commPrimary) 64 | & commHistory .~ (x^.commHistory <> y^.commHistory) 65 | 66 | instance Monoid CommodityInfo where 67 | mempty = defaultCommodityInfo 68 | x `mappend` y = x <> y 69 | 70 | -- | Return a 'CommodityInfo' with defaults selected for all fields. It is 71 | -- intended that at least one field of the result will be modified 72 | -- immediately. 73 | defaultCommodityInfo :: CommodityInfo 74 | defaultCommodityInfo = CommodityInfo 75 | { _commSymbol = "" 76 | , _commPrecision = 0 77 | , _commSuffixed = False 78 | , _commSeparated = True 79 | , _commThousands = True 80 | , _commDecimalComma = False 81 | , _commNoMarket = False 82 | , _commBuiltin = False 83 | , _commKnown = False 84 | , _commPrimary = False 85 | , _commHistory = IntMap.empty 86 | } 87 | 88 | defaultPrimaryCommodityInfo :: Text -> CommodityInfo 89 | defaultPrimaryCommodityInfo sym = defaultCommodityInfo 90 | & commSymbol .~ sym 91 | & commPrecision .~ 2 92 | & commNoMarket .~ True 93 | & commKnown .~ True 94 | & commPrimary .~ True 95 | 96 | -- | A commodities map, relating commodity indices to information about 97 | -- those commodities. 98 | data CommodityMap = CommodityMap 99 | { _commodities :: !(IntMap CommodityInfo) 100 | } 101 | deriving (Eq, Read, Show) 102 | 103 | makeClassy ''CommodityMap 104 | 105 | instance Semigroup CommodityMap where 106 | CommodityMap x <> CommodityMap y = 107 | CommodityMap (IntMap.unionWith (<>) x y) 108 | 109 | instance Monoid CommodityMap where 110 | mempty = CommodityMap mempty 111 | x `mappend` y = x <> y 112 | -------------------------------------------------------------------------------- /commodities/Ledger/Commodity/History.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Ledger.Commodity.History 11 | ( findConversion 12 | , addConversion 13 | , intAStar 14 | , intAStarM 15 | ) where 16 | 17 | import Control.Applicative 18 | import Control.Lens 19 | import Control.Monad hiding (forM) 20 | import Control.Monad.Trans.State 21 | import Data.Functor.Identity 22 | import Data.IntMap (IntMap, Key) 23 | import qualified Data.IntMap as IntMap 24 | import Data.List (foldl') 25 | import qualified Data.Map as Map 26 | import Data.PSQueue (PSQ, Binding(..), minView) 27 | import qualified Data.PSQueue as PSQ 28 | import Data.Ratio 29 | import Data.Thyme.Time 30 | import Data.Traversable 31 | import Ledger.Commodity 32 | import Prelude hiding (lookup) 33 | 34 | -- | The following A* algorithm was written by Cale Gibbard, and modified here 35 | -- to apply to IntMap's instead of general Map's. 36 | data IntAStar c = IntAStar 37 | { visited :: !(IntMap c) 38 | , waiting :: !(PSQ Key c) 39 | , score :: !(IntMap c) 40 | , memoHeur :: !(IntMap c) 41 | , cameFrom :: !(IntMap Key) 42 | , end :: !(Maybe Key) 43 | } deriving Show 44 | 45 | intAStarInit :: (Num c, Ord c) => Key -> IntAStar c 46 | intAStarInit start = IntAStar 47 | { visited = IntMap.empty 48 | , waiting = PSQ.singleton start 0 49 | , score = IntMap.singleton start 0 50 | , memoHeur = IntMap.empty 51 | , cameFrom = IntMap.empty 52 | , end = Nothing 53 | } 54 | 55 | runIntAStarM :: (Monad m, Ord c, Num c) 56 | => (Key -> m (IntMap c)) -- adjacencies in graph 57 | -> (Key -> m c) -- heuristic distance to goal 58 | -> (Key -> m Bool) -- goal 59 | -> Key -- starting vertex 60 | -> m (IntAStar c) -- final state 61 | runIntAStarM graph heur goal start = aStar' (intAStarInit start) 62 | where 63 | aStar' s = case minView (waiting s) of 64 | Nothing -> return s 65 | Just (x :-> d, w') -> do 66 | g <- goal x 67 | if g 68 | then return (s { end = Just x }) 69 | else do 70 | ns <- graph x 71 | u <- foldM (expand x) 72 | (s { waiting = w' 73 | , visited = IntMap.insert x d (visited s) 74 | }) 75 | (IntMap.toList (ns IntMap.\\ visited s)) 76 | aStar' u 77 | 78 | expand x s (y,d) = do 79 | let v = score s IntMap.! x + d 80 | case PSQ.lookup y (waiting s) of 81 | Nothing -> do 82 | h <- heur y 83 | return $ link x y v 84 | (s { memoHeur = IntMap.insert y h (memoHeur s) }) 85 | Just _ -> return $ if v < score s IntMap.! y 86 | then link x y v s 87 | else s 88 | link x y v s 89 | = s { cameFrom = IntMap.insert y x (cameFrom s), 90 | score = IntMap.insert y v (score s), 91 | waiting = PSQ.insert y (v + memoHeur s IntMap.! y) (waiting s) } 92 | 93 | -- | This function computes an optimal (minimal distance) path through a graph 94 | -- in a best-first fashion, starting from a given starting point. 95 | intAStarM 96 | :: (Monad m, Ord c, Num c) 97 | => (Key -> m (IntMap c)) -- ^ The graph we are searching through, given as 98 | -- a function from vertices to their neighbours. 99 | -> (Key -> m c) -- ^ Heuristic distance to the (nearest) goal. 100 | -- This should never overestimate the distance, 101 | -- or else the path found may not be minimal. 102 | -> (Key -> m Bool) -- ^ The goal, specified as a boolean predicate 103 | -- on vertices. 104 | -> m Key -- ^ The vertex to start searching from. 105 | -> m (Maybe [Key]) -- ^ An optimal path, if any path exists. This 106 | -- excludes the starting vertex. 107 | intAStarM graph heur goal start = do 108 | sv <- start 109 | s <- runIntAStarM graph heur goal sv 110 | forM (end s) $ \e -> 111 | return . reverse 112 | . takeWhile (not . (== sv)) 113 | . iterate (cameFrom s IntMap.!) 114 | $ e 115 | 116 | -- | This function computes an optimal (minimal distance) path through a graph 117 | -- in a best-first fashion, starting from a given starting point. 118 | intAStar :: (Ord c, Num c) 119 | => (Key -> IntMap c) -- ^ The graph we are searching through, given as 120 | -- a function from vertices to their neighbours. 121 | -> (Key -> c) -- ^ Heuristic distance to the (nearest) goal. 122 | -- This should never overestimate the distance, or 123 | -- else the path found may not be minimal. 124 | -> (Key -> Bool) -- ^ The goal, specified as a boolean predicate on 125 | -- vertices. 126 | -> Key -- ^ The vertex to start searching from. 127 | -> Maybe [Key] -- ^ An optimal path, if any path exists. This 128 | -- excludes the starting vertex. 129 | intAStar graph heur goal start = 130 | runIdentity $ intAStarM 131 | (return . graph) 132 | (return . heur) 133 | (return . goal) 134 | (return start) 135 | 136 | -- | Lookup a price conversion from the source commodity to the target, using 137 | -- data from the given time or earlier. Result is Nothing if no conversion 138 | -- can be found, or else the best conversion ratio plus the time of the 139 | -- oldest link. 140 | findConversion :: Commodity -- ^ Source commodity 141 | -> Commodity -- ^ Target commodity 142 | -> UTCTime -- ^ Look for conversions on or before this 143 | -> CommodityMap -- ^ Set of commodities to search 144 | -> Maybe (UTCTime, Rational) 145 | findConversion f t time cm = 146 | let (keyPath, valuesMap) = 147 | flip runState IntMap.empty $ 148 | intAStarM g h (return . (== t)) (return f) 149 | in go valuesMap <$> keyPath 150 | where 151 | g c = do 152 | vm <- get 153 | let (!m, !sm) = IntMap.foldlWithKey' 154 | (\(!m', !sm') k cs -> 155 | case Map.lookupLE time cs of 156 | Nothing -> (m', sm') 157 | Just (u,r) -> 158 | (IntMap.insert k (diffUTCTime time u) m', 159 | IntMap.insert k (u, r) sm')) 160 | (IntMap.empty, IntMap.empty) 161 | (cm ^. commodities.ix c.commHistory) 162 | put $! IntMap.insert c sm vm 163 | return m 164 | 165 | h _goal = return 0 166 | 167 | go vm ks = (\(!x, !y, _) -> (x, y)) $ foldl' o (time, 1, f) ks 168 | where 169 | o (!w, !r, !s) u = let (w', r') = vm IntMap.! s IntMap.! u 170 | in (min w w', r / r', u) 171 | 172 | -- | Add a price conversion in the form of a ratio between two commodities at 173 | -- a specific point in time. 174 | addConversion :: Commodity -> Commodity -> UTCTime -> Rational 175 | -> State CommodityMap () 176 | addConversion f t time ratio = do 177 | commodities.at t %= fmap (addconv (1/ratio) ?? f) 178 | commodities.at f %= fmap (addconv ratio ?? t) 179 | where 180 | addconv r s t' = 181 | let c = s^.commHistory 182 | rm = case IntMap.lookup t' c of 183 | Nothing -> Map.singleton time r 184 | Just m -> Map.insert time r m 185 | in s & commHistory .~ IntMap.insert t' rm c 186 | -------------------------------------------------------------------------------- /commodities/Ledger/Commodity/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE PackageImports #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Ledger.Commodity.Parse where 6 | 7 | import Control.Applicative 8 | import Control.Lens 9 | import "mtl" Control.Monad.State.Class 10 | import qualified Data.IntMap.Strict as IntMap 11 | import Data.Semigroup 12 | import qualified Data.Text as T 13 | import Data.Text.Lazy (Text, unpack) 14 | --import qualified Data.Text.Lazy as TL 15 | import Ledger.Balance 16 | import Ledger.Commodity 17 | --import Text.Parser.Char 18 | --import Text.Parser.Combinators 19 | import Text.Trifecta.Parser 20 | import Text.Trifecta.Result 21 | 22 | parseBalance :: (MonadState CommodityMap m, Functor m, a ~ Rational) 23 | => Text -> m (Either BalanceError (Balance a)) 24 | parseBalance str = 25 | case parseString balanceParser mempty (unpack str) of 26 | Success (b, c) -> do 27 | len <- IntMap.size <$> use commodities 28 | commodities.at len .= Just c 29 | return . Right $ b 30 | Failure e -> 31 | return . Left $ BalanceParseError (T.pack (show e)) 32 | 33 | balanceParser :: a ~ Rational => Parser (Balance a, CommodityInfo) 34 | balanceParser = undefined 35 | -------------------------------------------------------------------------------- /commodities/Ledger/Commodity/Print.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ImpredicativeTypes #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE PackageImports #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | module Ledger.Commodity.Print 9 | ( printBalance 10 | , balance 11 | ) where 12 | 13 | import Control.Applicative 14 | import Control.Lens 15 | import Control.Monad 16 | import "mtl" Control.Monad.Reader.Class 17 | import Control.Monad.Trans.Reader (runReader) 18 | import Control.Monad.Trans.State (evalState) 19 | import Control.Monad.Trans.Writer 20 | import qualified Data.IntMap.Strict as IntMap 21 | import Data.List 22 | import Data.List.Split 23 | import Data.Maybe (fromMaybe) 24 | import Data.Number.CReal 25 | import Data.Text.Lazy (Text, pack) 26 | --import qualified Data.Text.Lazy as TL 27 | import Data.Text.Lazy.Builder 28 | import Ledger.Balance 29 | import Ledger.Commodity 30 | import Ledger.Commodity.Parse 31 | 32 | printBalance :: (MonadReader CommodityMap m, Functor m, a ~ Rational) 33 | => Balance a 34 | -> m Text 35 | printBalance Zero = return "0" 36 | printBalance (Plain x) = return $ pack (show x) 37 | printBalance x = toLazyText <$> execWriterT (buildBalance x) 38 | 39 | buildBalance :: (MonadReader CommodityMap m, Functor m, a ~ Rational) 40 | => Balance a 41 | -> WriterT Builder m () 42 | buildBalance (Amount c q) = do 43 | cm <- fromMaybe defaultCommodityInfo <$> view (commodities.at c) 44 | 45 | unless (cm^.commSuffixed) $ do 46 | outputSymbol cm 47 | when (cm^.commSeparated) $ 48 | tell $ fromLazyText " " 49 | 50 | tell $ fromString (formatAmount cm) 51 | 52 | when (cm^.commSuffixed) $ do 53 | when (cm^.commSeparated) $ 54 | tell $ fromLazyText " " 55 | outputSymbol cm 56 | where 57 | outputSymbol cm = tell $ fromText (cm^.commSymbol) 58 | 59 | formatAmount cm = 60 | let prec = cm^.commPrecision 61 | str = showCReal prec (fromRational q) 62 | (n, m) = case break (== '.') str of 63 | (xs, '.':ys) -> (xs, ys) 64 | (xs, ys) -> (xs, ys) 65 | len = length m 66 | (com, per) = if cm^.commDecimalComma 67 | then (".", ",") 68 | else (",", ".") 69 | n' = if cm^.commThousands 70 | then reverse . intercalate com . chunksOf 3 . reverse $ n 71 | else n 72 | m' = if len < prec 73 | then m ++ replicate (prec - len) '0' 74 | else m 75 | in intercalate per [n', m'] 76 | 77 | buildBalance (Balance xs) = 78 | mapM_ (buildBalance . uncurry Amount) $ IntMap.toList xs 79 | 80 | buildBalance _ = return () 81 | 82 | balance :: a ~ Rational => CommodityMap -> Iso' (Balance a) Text 83 | balance pool = iso fromBalance toBalance 84 | where 85 | toBalance str = flip evalState pool $ do 86 | eb <- parseBalance str 87 | return $ case eb of 88 | Left (_ :: BalanceError) -> Zero 89 | Right b -> b 90 | fromBalance = flip runReader pool . printBalance 91 | -------------------------------------------------------------------------------- /commodities/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain -------------------------------------------------------------------------------- /commodities/TAGS: -------------------------------------------------------------------------------- 1 | 2 | src/Ledger.hs,20 3 | module Ledger (0,1 4 | 5 | src/Ledger/Amount.hs,219 6 | module Ledger.Amount where2,3 7 | extendByDigits ::9,10 8 | extendByDigits =10,11 9 | instance Ord12,13 10 | x@(Amount xc xq _ xkp) `quotRem` Amount _ yq _ _39,40 11 | overAmount ::53,54 12 | overAmount f54,55 13 | zero ::56,57 14 | zero =57,58 15 | 16 | src/Ledger/Commodity.hs,87 17 | module Ledger.Commodity where0,1 18 | ifCommoditiesMatch ::8,9 19 | ifCommoditiesMatch op9,10 20 | 21 | src/Ledger/Errors.hs,301 22 | module Ledger.Errors where2,3 23 | data LedgerException =9,10 24 | data LedgerException = CommodityMismatch {9,10 25 | data LedgerException = CommodityMismatch { leCmOperator ::9,10 26 | , leCmLeft ::10,11 27 | , leCmRight ::11,12 28 | 29 | src/Ledger/Types.hs,428 30 | module Ledger.Types where0,1 31 | data Commodity =5,6 32 | data Commodity = Commodity {5,6 33 | data Commodity = Commodity { cmdtyName ::5,6 34 | , cmdtyPrecision ::6,7 35 | data Amount =9,10 36 | data Amount = Amount {9,10 37 | data Amount = Amount { amtCommodity ::9,10 38 | , amtQuantity ::10,11 39 | , amtPrecision ::11,12 40 | , amtKeepPrecision ::12,13 41 | 42 | src/Ledger/Utils.hs,104 43 | module Ledger.Utils where0,1 44 | maybeEqual ::2,3 45 | maybeEqual _3,4 46 | maybeEqualBy ::7,8 47 | maybeEqualBy _8,9 48 | Amount src/Ledger/Types.hs 10 49 | Amount src/Ledger/Types.hs 10 50 | Commodity src/Ledger/Types.hs 6 51 | Commodity src/Ledger/Types.hs 6 52 | CommodityMismatch src/Ledger/Errors.hs 10 53 | Ledger src/Ledger.hs 1 54 | Ledger.Amount src/Ledger/Amount.hs 3 55 | Ledger.Commodity src/Ledger/Commodity.hs 1 56 | Ledger.Errors src/Ledger/Errors.hs 3 57 | Ledger.Types src/Ledger/Types.hs 1 58 | Ledger.Utils src/Ledger/Utils.hs 1 59 | LedgerException src/Ledger/Errors.hs 10 60 | amtCommodity src/Ledger/Types.hs 10 61 | amtKeepPrecision src/Ledger/Types.hs 13 62 | amtPrecision src/Ledger/Types.hs 12 63 | amtQuantity src/Ledger/Types.hs 11 64 | cmdtyName src/Ledger/Types.hs 6 65 | cmdtyPrecision src/Ledger/Types.hs 7 66 | extendByDigits src/Ledger/Amount.hs 10 67 | extendByDigits src/Ledger/Amount.hs 11 68 | ifCommoditiesMatch src/Ledger/Commodity.hs 9 69 | ifCommoditiesMatch src/Ledger/Commodity.hs 10 70 | instance src/Ledger/Amount.hs 13 71 | leCmLeft src/Ledger/Errors.hs 11 72 | leCmOperator src/Ledger/Errors.hs 10 73 | leCmRight src/Ledger/Errors.hs 12 74 | maybeEqual src/Ledger/Utils.hs 3 75 | maybeEqual src/Ledger/Utils.hs 4 76 | maybeEqualBy src/Ledger/Utils.hs 8 77 | maybeEqualBy src/Ledger/Utils.hs 9 78 | overAmount src/Ledger/Amount.hs 54 79 | overAmount src/Ledger/Amount.hs 55 80 | quotRem src/Ledger/Amount.hs 40 81 | zero src/Ledger/Amount.hs 57 82 | zero src/Ledger/Amount.hs 58 83 | -------------------------------------------------------------------------------- /commodities/commodities.cabal: -------------------------------------------------------------------------------- 1 | Name: commodities 2 | Version: 0.2.0.1 3 | Synopsis: Library for working with commoditized amounts and price histories 4 | Description: Library for working with commoditized amounts and price histories 5 | License-file: LICENSE 6 | License: BSD3 7 | Author: John Wiegley 8 | Maintainer: johnw@newartisans.com 9 | Build-Type: Simple 10 | Cabal-Version: >= 1.10 11 | Category: Finance 12 | 13 | source-repository head 14 | type: git 15 | location: git://github.com/ledger/ledger4.git 16 | 17 | library 18 | default-language: Haskell98 19 | ghc-options: -Wall 20 | exposed-modules: 21 | Ledger.Balance 22 | Ledger.Commodity 23 | Ledger.Commodity.History 24 | Ledger.Commodity.Parse 25 | Ledger.Commodity.Print 26 | build-depends: 27 | base >= 3 && < 5 28 | , PSQueue >= 1.1 29 | , comonad >= 4.0 30 | , containers >= 0.5.0.0 31 | , distributive >= 0.3.2 32 | , failure >= 0.2 33 | , keys >= 3.10 34 | , lens >= 3.10 35 | , linear >= 1.3.1 36 | , mtl >= 2.1.2 37 | , numbers >= 3000.2.0.0 38 | , parsers >= 0.10.1.1 39 | , semigroups >= 0.12 40 | , semigroupoids >= 4.0 41 | , split >= 0.2.2 42 | , text >= 0.11.3.1 43 | , thyme >= 0.3.1.0 44 | , transformers 45 | , trifecta >= 1.2.1.1 46 | 47 | test-suite doctests 48 | default-language: Haskell98 49 | type: exitcode-stdio-1.0 50 | main-is: doctests.hs 51 | ghc-options: -Wall 52 | hs-source-dirs: test 53 | build-depends: 54 | base >= 3 && < 5 55 | , directory >= 1.0 && < 1.4 56 | , doctest >= 0.8 && < 0.12 57 | , filepath >= 1.3 && < 1.5 58 | 59 | Test-suite test 60 | default-language: Haskell98 61 | type: exitcode-stdio-1.0 62 | main-is: Main.hs 63 | ghc-options: -Wall 64 | hs-source-dirs: test 65 | build-depends: 66 | base >= 3 && < 5 67 | , commodities 68 | , QuickCheck 69 | , hspec 70 | , hspec-expectations 71 | , containers 72 | , lens 73 | , semigroups 74 | , thyme 75 | , transformers 76 | -------------------------------------------------------------------------------- /commodities/default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, comonad, containers, directory, distributive 2 | , doctest, failure, filepath, hspec, hspec-expectations, keys, lens 3 | , linear, mtl, numbers, parsers, PSQueue, QuickCheck, semigroupoids 4 | , semigroups, split, stdenv, text, thyme, transformers, trifecta 5 | }: 6 | mkDerivation { 7 | pname = "commodities"; 8 | version = "0.2.0"; 9 | src = ./.; 10 | libraryHaskellDepends = [ 11 | base comonad containers distributive failure keys lens linear mtl 12 | numbers parsers PSQueue semigroupoids semigroups split text thyme 13 | transformers trifecta 14 | ]; 15 | testHaskellDepends = [ 16 | base containers directory doctest filepath hspec hspec-expectations 17 | lens QuickCheck semigroups thyme transformers 18 | ]; 19 | description = "Library for working with commoditized amounts and price histories"; 20 | license = stdenv.lib.licenses.bsd3; 21 | } 22 | -------------------------------------------------------------------------------- /commodities/test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Exception 6 | import Control.Lens 7 | import Control.Monad.Trans.State 8 | import qualified Data.IntMap as IntMap 9 | import qualified Data.Map as Map 10 | import Data.Ratio 11 | import Data.Thyme 12 | import Data.Thyme.Time 13 | import Ledger.Commodity 14 | import Ledger.Commodity.History 15 | import Test.Hspec 16 | import Test.QuickCheck 17 | 18 | main :: IO () 19 | main = hspec $ do 20 | describe "Sample tests" $ do 21 | it "returns the first element of a list" $ 22 | head [23 ..] `shouldBe` (23 :: Int) 23 | 24 | it "returns the first element of an *arbitrary* list" $ 25 | property $ \x xs -> head (x:xs) == (x :: Int) 26 | 27 | it "throws an exception if used with an empty list" $ 28 | evaluate (head []) `shouldThrow` anyException 29 | 30 | describe "Ledger.Commodity.History" $ do 31 | it "works with testMap" $ do 32 | let cm = testMap moment 33 | findConversion 1 3 moment cm 34 | `shouldBe` Just (oneHourAgo, 400 % 249) 35 | findConversion 1 3 (addUTCTime (-7000) moment) cm 36 | `shouldBe` Just (oneDayAgo, 50 % 33) 37 | 38 | it "works with testMap'" $ do 39 | let cm' = testMap' moment 40 | findConversion 1 3 moment cm' 41 | `shouldBe` Just (oneHourAgo, 8 % 5) 42 | findConversion 1 3 (addUTCTime (-7000) moment) cm' 43 | `shouldBe` Just (oneDayAgo, 3 % 2) 44 | where 45 | moment = UTCTime (ModifiedJulianDay 50000) (secondsToDiffTime 0) 46 | ^. from utcTime 47 | oneHourAgo = addUTCTime (-3600) moment 48 | oneDayAgo = addUTCTime (-(24 * 3600)) moment 49 | 50 | testMap :: UTCTime -> CommodityMap 51 | testMap now = 52 | let oneHourAgo = addUTCTime (-3600) now 53 | oneDayAgo = addUTCTime (-(24 * 3600)) now 54 | 55 | usd = (defaultPrimaryCommodityInfo "USD") 56 | & commHistory .~ 57 | IntMap.fromList [ (2, Map.fromList [(oneHourAgo, 0.75)]) 58 | , (3, Map.fromList [(oneDayAgo, 0.66)]) 59 | ] 60 | cad = (defaultPrimaryCommodityInfo "CAD") 61 | & commHistory .~ 62 | IntMap.fromList [ (1, Map.fromList [(oneHourAgo, 1.33)]) 63 | , (3, Map.fromList [(oneHourAgo, 0.83)]) 64 | ] 65 | eur = (defaultPrimaryCommodityInfo "EUR") 66 | & commHistory .~ 67 | IntMap.fromList [ (1, Map.fromList [(oneDayAgo, 1.5)]) 68 | , (2, Map.fromList [(oneHourAgo, 1.2)]) 69 | ] 70 | in CommodityMap $ IntMap.fromList 71 | [ (1, usd) 72 | , (2, cad) 73 | , (3, eur) 74 | ] 75 | 76 | testMap' :: UTCTime -> CommodityMap 77 | testMap' now = 78 | let usd = defaultPrimaryCommodityInfo "USD" 79 | cad = defaultPrimaryCommodityInfo "CAD" 80 | eur = defaultPrimaryCommodityInfo "EUR" 81 | 82 | cm = CommodityMap $ IntMap.fromList 83 | [ (1, usd) 84 | , (2, cad) 85 | , (3, eur) 86 | ] 87 | in flip execState cm $ do 88 | let oneHourAgo = addUTCTime (-3600) now 89 | oneDayAgo = addUTCTime (-(24 * 3600)) now 90 | addConversion 1 2 oneHourAgo (3 % 4) 91 | addConversion 1 3 oneDayAgo (2 % 3) 92 | addConversion 2 3 oneHourAgo (5 % 6) 93 | -------------------------------------------------------------------------------- /commodities/test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest 4 | import System.Directory 5 | import System.FilePath 6 | import Control.Applicative 7 | import Control.Monad 8 | import Data.List 9 | 10 | main :: IO () 11 | main = getSources >>= \sources -> doctest $ 12 | "-i." 13 | : "-idist/build/autogen" 14 | : "-optP-include" 15 | : "-optPdist/build/autogen/cabal_macros.h" 16 | : sources 17 | 18 | getSources :: IO [FilePath] 19 | getSources = filter (\x -> ".hs" `isSuffixOf` x) <$> go "Ledger" 20 | where 21 | go dir = do 22 | (dirs, files) <- getFilesAndDirectories dir 23 | (files ++) . concat <$> mapM go dirs 24 | 25 | getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) 26 | getFilesAndDirectories dir = do 27 | c <- map (dir ) . filter (`notElem` ["..", "."]) 28 | <$> getDirectoryContents dir 29 | (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c 30 | -------------------------------------------------------------------------------- /ledger-expr/Ledger/Expr.hs: -------------------------------------------------------------------------------- 1 | module Ledger.Expr where 2 | 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | data ExprF :: (* -> *) -> * -> * where 11 | Const :: Int -> ExprF r Int 12 | Add :: r Int -> r Int -> ExprF r Int 13 | Mul :: r Int -> r Int -> ExprF r Int 14 | Cond :: r Bool -> r a -> r a -> ExprF r a 15 | IsEq :: r Int -> r Int -> ExprF r Bool -------------------------------------------------------------------------------- /ledger-expr/doc/LICENSE: -------------------------------------------------------------------------------- 1 | opyright (c) 2012 John Wiegley 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /ledger-expr/ledger-expr.cabal: -------------------------------------------------------------------------------- 1 | Name: ledger-parse 2 | Version: 4.0.0 3 | Synopsis: TBD 4 | Description: TBD 5 | License-file: doc/LICENSE 6 | License: BSD3 7 | Author: John Wiegley 8 | Maintainer: johnw@newartisans.com 9 | Build-Type: Simple 10 | Cabal-Version: >=1.10 11 | Category: FFI 12 | 13 | Source-repository head 14 | type: git 15 | location: git://github.com/ledger/ledger4.git 16 | 17 | test-suite doctests 18 | default-language: Haskell98 19 | type: exitcode-stdio-1.0 20 | main-is: doctests.hs 21 | build-depends: 22 | base == 4.* 23 | , directory >= 1.0 24 | , doctest >= 0.8 25 | , filepath >= 1.3 26 | ghc-options: -Wall -Werror 27 | hs-source-dirs: test 28 | 29 | Library 30 | default-language: Haskell98 31 | ghc-options: -Wall -fno-warn-orphans -threaded 32 | build-depends: 33 | base >= 3 && < 5 34 | , system-filepath >= 0.4.7 35 | , text >= 0.11.2 36 | , bytestring >= 0.9.2.1 37 | , trifecta >= 0.91 38 | , parsers >= 0.3.2 39 | exposed-modules: 40 | Ledger.Expr -------------------------------------------------------------------------------- /ledger-expr/test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest 4 | import System.Directory 5 | import System.FilePath 6 | import Control.Applicative 7 | import Control.Monad 8 | import Data.List 9 | 10 | main :: IO () 11 | main = getSources >>= \sources -> doctest $ 12 | "-i." 13 | : "-idist/build/autogen" 14 | : "-optP-include" 15 | : "-optPdist/build/autogen/cabal_macros.h" 16 | : sources 17 | 18 | getSources :: IO [FilePath] 19 | getSources = filter (\x -> ".hs" `isSuffixOf` x) <$> go "src" 20 | where 21 | go dir = do 22 | (dirs, files) <- getFilesAndDirectories dir 23 | (files ++) . concat <$> mapM go dirs 24 | 25 | getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) 26 | getFilesAndDirectories dir = do 27 | c <- map (dir ) . filter (`notElem` ["..", "."]) 28 | <$> getDirectoryContents dir 29 | (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c 30 | -------------------------------------------------------------------------------- /ledger-parse/.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | /TAGS 3 | -------------------------------------------------------------------------------- /ledger-parse/Ledger/Parser/Text.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Ledger.Parser.Text 4 | ( parseJournalFile 5 | , RawJournal(..) 6 | , RawEntity(..) 7 | , RawEntityInSitu(..) 8 | , RawPosting(..) 9 | , RawTransaction(..) 10 | , RawAutoTxn(..) 11 | , RawPeriodTxn(..) 12 | -- , main 13 | ) where 14 | 15 | import Control.Applicative 16 | import Data.ByteString as B hiding (pack, unpack, singleton, 17 | zipWith, concat) 18 | import Data.Maybe 19 | import qualified Data.Text.Encoding as E 20 | import Filesystem.Path.CurrentOS hiding (concat) 21 | import Prelude hiding (FilePath, readFile, until) 22 | import Text.Parser.Combinators 23 | import Text.Parser.LookAhead 24 | import Text.Parser.Token 25 | import Text.Trifecta 26 | import Text.Trifecta.Delta 27 | -- import Control.DeepSeq 28 | -- import Criterion 29 | -- import Criterion.Main 30 | 31 | infixl 4 <$!> 32 | 33 | (<$!>) :: TokenParsing m => (a -> b) -> m a -> m b 34 | f <$!> ma = ($!) <$> pure f <*> ma 35 | 36 | data RawJournal = RawJournal [RawEntity] 37 | deriving (Show, Eq) 38 | 39 | data RawEntity = Whitespace String 40 | | FileComment String 41 | | Directive { directiveChar :: Maybe Char 42 | , directiveName :: !String 43 | , directiveArg :: Maybe String } 44 | | RawTransactionEntity RawTransaction 45 | | RawAutoTxnEntity RawAutoTxn 46 | | RawPeriodTxnEntity RawPeriodTxn 47 | | EndOfFile 48 | deriving (Show, Eq) 49 | 50 | data RawEntityInSitu = RawEntityInSitu { rawEntityIndex :: !Int 51 | , rawEntityStartPos :: !Rendering 52 | , rawEntity :: !RawEntity 53 | , rawEntityEndPos :: !Rendering } 54 | 55 | instance Show RawEntityInSitu where 56 | show x = show (rawEntity x) ++ "\n" 57 | 58 | data RawPosting = RawPosting { rawPostState :: Maybe Char 59 | , rawPostAccount :: !String 60 | , rawPostAmount :: Maybe String 61 | , rawPostNote :: Maybe String } 62 | | RawPostingNote !String 63 | deriving (Show, Eq) 64 | 65 | data RawTransaction = RawTransaction { rawTxnDate :: !String 66 | , rawTxnDateAux :: Maybe String 67 | , rawTxnState :: Maybe Char 68 | , rawTxnCode :: Maybe String 69 | , rawTxnDesc :: !String 70 | , rawTxnNote :: Maybe String 71 | , rawTxnPosts :: ![RawPosting] } 72 | deriving (Show, Eq) 73 | 74 | data RawAutoTxn = RawAutoTxn { rawATxnQuery :: !String 75 | , rawATxnPosts :: ![RawPosting] } 76 | deriving (Show, Eq) 77 | 78 | data RawPeriodTxn = RawPeriodTxn { rawPTxnPeriod :: !String 79 | , rawPTxnPosts :: ![RawPosting] } 80 | deriving (Show, Eq) 81 | 82 | txnDateParser :: TokenParsing m => m String 83 | txnDateParser = some (digit <|> oneOf "/-." <|> letter) 84 | "transaction date" 85 | 86 | longSep :: CharParsing m => m () 87 | longSep = () <$ (try (char ' ' *> char ' ') <|> tab) 88 | 89 | noteParser :: (LookAheadParsing m, CharParsing m) => m String 90 | noteParser = char ';' *> manyTill anyChar (try (lookAhead endOfLine)) 91 | "note" 92 | 93 | longSepOrEOL :: (LookAheadParsing m, CharParsing m) => m () 94 | longSepOrEOL = try (lookAhead (longSep <|> endOfLine)) 95 | 96 | longSepOrEOLIf :: (LookAheadParsing m, CharParsing m) => m p -> m () 97 | longSepOrEOLIf p = try (lookAhead ((() <$ longSep <* p) <|> endOfLine)) 98 | 99 | until :: CharParsing m => m () -> m String 100 | until end = (:) <$> noneOf "\r\n" <*> manyTill anyChar end 101 | 102 | tokenP :: TokenParsing m => m p -> m p 103 | tokenP p = p <* skipMany spaceChars 104 | 105 | postingParser :: (LookAheadParsing m, TokenParsing m) => m RawPosting 106 | postingParser = 107 | (RawPosting <$!> (some spaceChars *> 108 | optional (tokenP (char '*' <|> char '!'))) 109 | <*> tokenP (until longSepOrEOL) 110 | <*> optional (tokenP (until (longSepOrEOLIf (char ';')))) 111 | <*> (optional noteParser <* endOfLine) 112 | "posting") 113 | <|> 114 | (RawPostingNote <$!> (concat <$!> 115 | some ((++) <$!> (some spaceChars *> noteParser) 116 | <*> ((:[]) <$> endOfLineChar))) 117 | "posting note") 118 | 119 | spaceChars :: CharParsing m => m () 120 | spaceChars = () <$ oneOf " \t" 121 | 122 | regularTxnParser :: (LookAheadParsing m, TokenParsing m) => m RawEntity 123 | regularTxnParser = RawTransactionEntity <$!> go 124 | where go = RawTransaction 125 | <$!> txnDateParser 126 | <*> optional (char '=' *> txnDateParser) 127 | <*> (many spaceChars *> 128 | optional (tokenP (char '*' <|> char '!'))) 129 | <*> optional 130 | (tokenP (parens (many (noneOf ")\r\n")))) 131 | <*> tokenP (until (longSepOrEOLIf (char ';'))) 132 | <*> optional noteParser 133 | <*> (endOfLine *> some postingParser) 134 | "regular transaction" 135 | 136 | automatedTxnParser :: (LookAheadParsing m, TokenParsing m) => m RawEntity 137 | automatedTxnParser = RawAutoTxnEntity <$!> go 138 | where go = RawAutoTxn 139 | <$!> (tokenP (char '=') *> 140 | manyTill anyChar (try (lookAhead endOfLine))) 141 | <*> (endOfLine *> some postingParser) 142 | "automated transaction" 143 | 144 | periodicTxnParser :: (LookAheadParsing m, TokenParsing m) => m RawEntity 145 | periodicTxnParser = RawPeriodTxnEntity <$!> go 146 | where go = RawPeriodTxn 147 | <$!> (tokenP (char '~') *> 148 | manyTill anyChar (try (lookAhead endOfLine))) 149 | <*> (endOfLine *> some postingParser) 150 | "periodic transaction" 151 | 152 | transactionParser :: (LookAheadParsing m, TokenParsing m) => m RawEntity 153 | transactionParser = regularTxnParser 154 | <|> automatedTxnParser 155 | <|> periodicTxnParser 156 | "transaction" 157 | 158 | directiveParser :: (LookAheadParsing m, TokenParsing m) => m RawEntity 159 | directiveParser = 160 | Directive <$!> optional (oneOf "@!") 161 | <*> ((:) <$!> letter <*> tokenP (many alphaNum)) 162 | <*> (optional 163 | ((:) <$!> noneOf "\r\n" 164 | <*> manyTill anyChar (try (lookAhead endOfLine))) 165 | <* endOfLine) 166 | "directive" 167 | 168 | endOfLine :: CharParsing m => m () 169 | endOfLine = () <$ endOfLineChar 170 | 171 | endOfLineChar :: CharParsing m => m Char 172 | endOfLineChar = skipOptional (char '\r') *> char '\n' 173 | 174 | commentParser :: (LookAheadParsing m, TokenParsing m) => m RawEntity 175 | commentParser = FileComment 176 | <$!> (concat <$!> 177 | some ((++) <$!> noteParser 178 | <*> ((:[]) <$> endOfLineChar))) 179 | "comment" 180 | 181 | whitespaceParser :: TokenParsing m => m RawEntity 182 | whitespaceParser = Whitespace <$!> some space "whitespace" 183 | 184 | entityParser :: (LookAheadParsing m, TokenParsing m) => m RawEntity 185 | entityParser = directiveParser 186 | <|> commentParser 187 | <|> whitespaceParser 188 | <|> transactionParser 189 | "journal" 190 | 191 | rendCaret :: DeltaParsing m => m Rendering 192 | rendCaret = addCaret <$!> position <*> rend 193 | 194 | journalParser :: (LookAheadParsing m, DeltaParsing m) => m [RawEntityInSitu] 195 | journalParser = 196 | many (RawEntityInSitu <$!> pure 0 <*> rendCaret <*> entityParser <*> rendCaret) 197 | 198 | parseJournalFile :: FilePath -> ByteString -> Result [RawEntityInSitu] 199 | parseJournalFile file contents = 200 | let filepath = either id id $ toText file 201 | start = Directed (E.encodeUtf8 filepath) 0 0 0 0 202 | in zipWith (\e i -> e { rawEntityIndex = i}) 203 | <$> parseByteString journalParser start contents 204 | <*> pure [1..] 205 | 206 | -- testme :: IO (Result [RawEntityInSitu]) 207 | -- testme = 208 | -- let file = "/Users/johnw/Documents/Finances/ledger.dat" 209 | -- in parseJournalFile (fromText (T.pack file)) <$> B.readFile file 210 | 211 | -- instance NFData RawEntityInSitu 212 | -- instance NFData (Result a) 213 | 214 | -- main = do let file = "/Users/johnw/Documents/Finances/ledger.dat" 215 | -- bs <- B.readFile file 216 | -- defaultMain [ 217 | -- bench "main" $ nf (parseJournalFile (fromText (T.pack file))) bs ] 218 | 219 | -- Text.hs ends here 220 | -------------------------------------------------------------------------------- /ledger-parse/doc/LICENSE: -------------------------------------------------------------------------------- 1 | opyright (c) 2012 John Wiegley 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /ledger-parse/ledger-parse.cabal: -------------------------------------------------------------------------------- 1 | Name: ledger-parse 2 | Version: 4.0.0 3 | Synopsis: TBD 4 | Description: TBD 5 | License-file: doc/LICENSE 6 | License: BSD3 7 | Author: John Wiegley 8 | Maintainer: johnw@newartisans.com 9 | Build-Type: Simple 10 | Cabal-Version: >=1.10 11 | Category: FFI 12 | 13 | Source-repository head 14 | type: git 15 | location: git://github.com/ledger/ledger4.git 16 | 17 | test-suite doctests 18 | default-language: Haskell98 19 | type: exitcode-stdio-1.0 20 | main-is: doctests.hs 21 | build-depends: 22 | base == 4.* 23 | , directory >= 1.0 24 | , doctest >= 0.8 25 | , filepath >= 1.3 26 | ghc-options: -Wall -Werror 27 | hs-source-dirs: test 28 | 29 | Library 30 | default-language: Haskell98 31 | ghc-options: -Wall -fno-warn-orphans -threaded 32 | build-depends: 33 | base >= 3 && < 5 34 | , system-filepath >= 0.4.7 35 | , text >= 0.11.2 36 | , bytestring >= 0.9.2.1 37 | , trifecta >= 0.91 38 | , parsers >= 0.5 39 | exposed-modules: 40 | -------------------------------------------------------------------------------- /ledger-parse/test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest 4 | import System.Directory 5 | import System.FilePath 6 | import Control.Applicative 7 | import Control.Monad 8 | import Data.List 9 | 10 | main :: IO () 11 | main = getSources >>= \sources -> doctest $ 12 | "-i." 13 | : "-idist/build/autogen" 14 | : "-optP-include" 15 | : "-optPdist/build/autogen/cabal_macros.h" 16 | : sources 17 | 18 | getSources :: IO [FilePath] 19 | getSources = filter (\x -> ".hs" `isSuffixOf` x) <$> go "src" 20 | where 21 | go dir = do 22 | (dirs, files) <- getFilesAndDirectories dir 23 | (files ++) . concat <$> mapM go dirs 24 | 25 | getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) 26 | getFilesAndDirectories dir = do 27 | c <- map (dir ) . filter (`notElem` ["..", "."]) 28 | <$> getDirectoryContents dir 29 | (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c 30 | -------------------------------------------------------------------------------- /ledger-parse/test/testAmount.hs: -------------------------------------------------------------------------------- 1 | import Test.Hspec 2 | import Test.QuickCheck 3 | import Control.Exception (evaluate) 4 | 5 | main :: IO () 6 | main = hspec $ do 7 | describe "Ledger.Amount" $ do 8 | it "returns the first element of a list" $ do 9 | head [23 ..] `shouldBe` (23 :: Int) 10 | 11 | it "returns the first element of an *arbitrary* list" $ 12 | property $ \x xs -> head (x:xs) == (x :: Int) 13 | 14 | it "throws an exception if used with an empty list" $ do 15 | evaluate (head []) `shouldThrow` anyException -------------------------------------------------------------------------------- /sources.txt: -------------------------------------------------------------------------------- 1 | commodities/ 2 | --------------------------------------------------------------------------------