packages feed

trade-journal (empty) → 0.0.1

raw patch · 16 files changed

+2500/−0 lines, 16 filesdep +HUnitdep +aesondep +basesetup-changed

Dependencies added: HUnit, aeson, base, bytestring, cassava, containers, data-default, hedgehog, here, lens, megaparsec, mtl, optparse-applicative, pretty, pretty-show, profunctors, split, tasty, tasty-hedgehog, tasty-hunit, text, time, trade-journal, transformers, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, John Wiegley++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of John Wiegley nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Main where++import Control.Lens+import Data.Aeson hiding ((.=))+import qualified Data.ByteString.Lazy as BL+import Data.Foldable+import Data.Map (Map)+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.Text.Lazy.IO as TL+import GHC.Generics hiding (to)+import Journal.Amount+import Journal.Model+import Journal.Parse+import Options+import Text.Megaparsec (parse)+import Text.Megaparsec.Error++data Config = Config+  { splits :: Map Text [Amount 6],+    rounding :: Map Text (Amount 2)+  }+  deriving (Generic, Show, FromJSON)++newConfig :: Config+newConfig =+  Config+    { splits = mempty,+      rounding = mempty+    }++parseProcessPrint :: MonadFail m => FilePath -> TL.Text -> m TL.Text+parseProcessPrint path journal = do+  actions <- case parse parseJournal path journal of+    Left e -> fail $ errorBundlePretty e+    Right res -> pure res+  case processJournal actions of+    Left err ->+      error $ "Error processing journal " ++ path ++ ": " ++ show err+    Right j -> pure $ printJournal j++main :: IO ()+main = do+  opts <- getOptions+  forM_ (opts ^. files) $ \path -> do+    putStrLn $ "Reading journal " ++ path+    journal <- TL.decodeUtf8 <$> BL.readFile path+    TL.putStrLn =<< parseProcessPrint path journal
+ Options.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}++module Options where++import Control.Lens hiding (argument)+import Data.Data (Data)+import Data.Typeable (Typeable)+import GHC.Generics+import Options.Applicative++version :: String+version = "0.0.1"++copyright :: String+copyright = "2020"++tradeJournalSummary :: String+tradeJournalSummary =+  "trade-journal "+    ++ version+    ++ ", (C) "+    ++ copyright+    ++ " John Wiegley"++data Options = Options+  { _verbose :: Bool,+    _totals :: Bool,+    _files :: [FilePath]+  }+  deriving (Data, Show, Eq, Typeable, Generic)++makeLenses ''Options++newOptions :: Options+newOptions =+  Options+    { _verbose = False,+      _totals = False,+      _files = []+    }++tradeJournalOpts :: Parser Options+tradeJournalOpts =+  Options+    <$> switch+      ( short 'v'+          <> long "verbose"+          <> help "Report progress verbosely"+      )+    <*> switch+      ( long "totals"+          <> help "Show calculated totals for entries"+      )+    <*> some (argument str (metavar "FILE"))++optionsDefinition :: ParserInfo Options+optionsDefinition =+  info+    (helper <*> tradeJournalOpts)+    (fullDesc <> progDesc "" <> header tradeJournalSummary)++getOptions :: IO Options+getOptions = execParser optionsDefinition
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ src/Journal/Amount.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Journal.Amount+  ( Amount (..),+    _Amount,+    rounded,+    thousands,+    renderAmount,+    normalizeAmount,+    spreadAmounts,+    showAmount,+    amountToString,+    mpfr_RNDN,+    mpfr_RNDZ,+    mpfr_RNDU,+    mpfr_RNDD,+    mpfr_RNDA,+    mpfr_RNDF,+    mpfr_RNDNA,+    sign,+  )+where++import Control.Monad+import Data.Aeson+import Data.Char (isDigit)+import Data.Coerce+import Data.Data+import Data.Default+import Data.Function (on)+import Data.Int (Int64)+import Data.List (intercalate)+import Data.List.Split+import Data.Profunctor+import Data.Ratio+import Foreign.C.String+import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import GHC.Generics+import GHC.TypeLits+import Journal.Utils (Render (..))+import System.IO.Unsafe+import Text.PrettyPrint (text)+import Text.Show.Pretty as P+import Prelude hiding (Double, Float)++mpfr_RNDN, mpfr_RNDZ, mpfr_RNDU, mpfr_RNDD, mpfr_RNDA, mpfr_RNDF :: CUInt++mpfr_RNDNA :: CUInt++mpfr_RNDN = 0 -- round to nearest, with ties to even++mpfr_RNDZ = 1 -- round toward zero++mpfr_RNDU = 2 -- round toward +Inf++mpfr_RNDD = 3 -- round toward -Inf++mpfr_RNDA = 4 -- round away from zero++mpfr_RNDF = 5 -- faithful rounding++mpfr_RNDNA = 6 -- round to nearest, with ties away from zero (mpfr_round)++foreign import ccall unsafe "mpfr_free_str" c'mpfr_free_str :: CString -> IO ()++foreign import ccall unsafe "rational_to_str"+  c'rational_to_str ::+    CLong -> CULong -> CUInt -> CSize -> Ptr CString -> IO ()++newtype Amount (dec :: Nat) = Amount {getAmount :: Ratio Int64}+  deriving+    ( Generic,+      Data,+      Typeable,+      Ord,+      Num,+      Fractional,+      Real,+      RealFrac+    )++instance Default (Amount n) where+  def = 0++instance KnownNat n => PrettyVal (Amount n) where+  prettyVal = P.String . show++showAmount :: forall n. KnownNat n => CUInt -> Amount n -> String+showAmount rnd (Amount r) =+  unsafePerformIO $ alloca $ \bufPtr -> do+    c'rational_to_str+      (CLong (numerator r))+      (CULong (fromIntegral (denominator r)))+      rnd+      (CSize (fromIntegral (natVal (Proxy :: Proxy n))))+      bufPtr+    buf <- peek bufPtr+    str <- peekCString buf+    c'mpfr_free_str buf+    return str++instance KnownNat n => Eq (Amount n) where+  (==) = (==) `on` show++instance KnownNat n => Show (Amount n) where+  show = amountToString 2++instance KnownNat n => Read (Amount n) where+  readsPrec _d = \case+    '-' : xs -> map (\(x, y) -> (negate x, y)) (readNum xs)+    xs -> readNum xs+    where+      readNum r = case takeWhile isDigit r of+        [] -> error $ "Not an amount: " ++ r+        num -> case dropWhile isDigit r of+          ('.' : den) ->+            let den' = takeWhile isDigit den+                rem' = dropWhile isDigit den+             in [(Amount (read (num ++ den') % 10 ^ length den'), rem')]+          xs -> [(Amount (read num % 1), xs)]++instance KnownNat n => Render (Amount n) where+  rendered = text . show++instance KnownNat n => ToJSON (Amount n) where+  toJSON = Number . fromRational . toRational . getAmount++instance KnownNat n => FromJSON (Amount n) where+  parseJSON (Number n) = pure $ Amount (fromRational (toRational n))+  parseJSON v = error $ "Expected Amount, saw: " ++ show v++-- _Amount :: KnownNat n => Prism' String (Amount n)+_Amount ::+  (KnownNat n, Choice p, Applicative f) =>+  p (Amount n) (f (Amount n)) ->+  p String (f String)+_Amount = dimap read (fmap show)++-- rounded :: (KnownNat m, KnownNat n) => Iso' (Amount n) (Amount m)+rounded ::+  (Profunctor p, Functor f) =>+  p (Amount m) (f (Amount m)) ->+  p (Amount n) (f (Amount n))+rounded = dimap coerce (fmap coerce)++amountToString :: KnownNat n => Int -> Amount n -> String+amountToString n = touchup . cleanup n . showAmount mpfr_RNDNA+  where+    touchup s+      | last s == '.' = take (length s - 1) s+      | otherwise = s+    cleanup m t+      | len > m && last t == '0' = cleanup m (take (length t - 1) t)+      | otherwise = t+      where+        len = length (last (splitOn "." t))++thousands :: forall n. KnownNat n => Amount n -> String+thousands d = intercalate "." $ case splitOn "." str of+  x : xs -> (reverse . go . reverse) x+    : case xs of+      y : ys -> expand y : ys+      _ | isInt -> ["00"]+      _ -> []+  xs -> xs+  where+    isInt = case natVal (Proxy :: Proxy n) of+      0 -> True+      _ -> False+    str+      | isInt = show (floor d :: Int)+      | otherwise = amountToString 2 d+    go (x : y : z : []) = x : y : z : []+    go (x : y : z : ['-']) = x : y : z : ['-']+    go (x : y : z : xs) = x : y : z : ',' : go xs+    go xs = xs+    expand [] = "00"+    expand (x : []) = x : "0"+    expand xs = xs++renderAmount :: KnownNat n => Amount n -> String+renderAmount d+  | fromIntegral (floor d :: Int) == d =+    thousands @0 (coerce d)+renderAmount d = thousands d++normalizeAmount :: KnownNat n => CUInt -> Amount n -> Amount n+normalizeAmount = (read .) . showAmount++-- Given a way of project a "count" from an element, an amount, and a list of+-- elements, divide the given amount among the elements each according to its+-- count. Thus, if passed a two element list with counts 60 and 40, the amount+-- would be divided 60% to the first, and 40% to the second.+spreadAmounts ::+  (KnownNat n, KnownNat m) =>+  (a -> Amount m) ->+  Amount n ->+  [a] ->+  [(Amount n, a)]+spreadAmounts f n input = go True input+  where+    diff = n - sum (map sump input)+    per = coerce n / shares+    shares = sum (map f input)+    sump l = coerce (f l * per)+    go _ [] = []+    go b (x : xs) = (sum', x) : go False xs+      where+        sum' = sump x + if b then diff else 0++sign :: (Num a, Ord a, Num b) => a -> b -> b+sign n = (if n < 0 then negate else id) . abs
+ src/Journal/Model.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Journal.Model+  ( processJournal,+    processJournalWithChanges,+    processActionsWithChanges,+  )+where++import Control.Applicative+import Control.Arrow+import Control.Exception hiding (handle)+import Control.Lens+import Control.Monad.Except+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State+import Control.Monad.Trans.Writer+import Data.Foldable+import Data.List (sortOn)+import Data.List (tails)+import Journal.Amount+import Journal.Split+import Journal.Types+import Journal.Utils+import Prelude hiding (Double, Float)++-- | Ideally, this module turns a stream of lots -- expressing intentions to+--   buy and sell at given prices -- into a record of transactions with the+--   broker where all gains and losses have been calculated.+processJournal :: MonadError JournalError m => Journal -> m Journal+processJournal =+  fmap (Journal . snd) . processActionsWithChanges . view actions++processJournalWithChanges ::+  MonadError JournalError m =>+  Journal ->+  m ([Change], Journal)+processJournalWithChanges =+  fmap (second Journal) . processActionsWithChanges . view actions++processActionsWithChanges ::+  MonadError JournalError m =>+  [Timed Action] ->+  m ([Change], [Timed Action])+processActionsWithChanges xs =+  fmap unzipBoth . (`evalStateT` newJournalState) $ do+    forM xs $ \x -> do+      let lot = x ^. item . _Lot+          macct = lot ^? details . traverse . _Account+          sym = lot ^. symbol+      zoom (accounts . at macct . non newAccountState) $ do+        zoom+          ( zipped3+              nextId+              balance+              (instruments . at sym . non newInstrumentState)+          )+          $ first (SawAction x :) <$> processAction x++checkNetAmount ::+  MonadError JournalError m =>+  Timed Action ->+  m (Timed Action)+checkNetAmount x+  | Just itemNet <- x ^? item . _Lot . details . traverse . _Net = do+    let calcNet = netAmount (x ^. item)+    if itemNet == calcNet+      then throwError $ NetAmountDoesNotMatch x calcNet itemNet+      else pure x+  | otherwise =+    pure $ x & item . _Lot . details <>~ [Net (netAmount (x ^. item))]++checkBalance ::+  MonadError JournalError m =>+  Timed Action ->+  StateT (Amount 2) m (Timed Action)+checkBalance x+  | Just itemBal <- x ^? item . _Lot . details . traverse . _Balance = do+    bal <- get+    let newBal = netAmount (x ^. item) + bal+    if itemBal == newBal+      then pure x+      else throwError $ BalanceDoesNotMatch x newBal itemBal+  | otherwise = do+    bal <- get+    let newBal = netAmount (x ^. item) + bal+    put newBal+    pure $ x & item . _Lot . details <>~ [Balance newBal]++processAction ::+  MonadError JournalError m =>+  Timed Action ->+  StateT (Int, Amount 2, InstrumentState) m ([Change], [Timed Action])+processAction =+    fmap unzipBoth . mapM applyChange <=< readonly . impliedChanges+  where+    applyChange chg = case chg of+      SawAction _ -> throwError $ ChangeNotFromImpliedChanges chg+      Result e -> do+        e' <- zoom _2 $ checkBalance e+        e'' <- lift $ checkNetAmount e'+        pure ([chg], [e''])+      Submit lot ->+        first (\xs -> chg : xs ++ [SubmitEnd])+          <$> processAction (Wash <$> lot)+      SubmitEnd -> pure ([chg], [])+      AddEvent e -> do+        ident <- use _1+        _1 += 1+        _3 . events . at ident ?= e+        pure ([chg], [])+      RemoveEvent ident -> do+        _3 . events . at ident .= Nothing+        pure ([chg], [])+      ReplaceEvent ident e -> do+        _3 . events . at ident ?= e+        pure ([chg], [])+      SaveWash name lot -> do+        _3 . washSales . at name+          %= \case Nothing -> Just [lot]; Just xs -> Just (lot : xs)+        pure ([chg], [])++-- | A specialized variant of 'foldM' with some arguments shifted around.+shortFoldM ::+  Monad m =>+  a ->+  [b] ->+  (b -> Maybe a -> m (Maybe a)) ->+  m (Maybe a)+shortFoldM z xs f = foldM (flip f) (Just z) xs++impliedChanges ::+  MonadError JournalError m =>+  Timed Action ->+  ReaderT (Int, Amount 2, InstrumentState) m [Change]+impliedChanges x = do+  hist <- asks (sortOn fst . toListOf (_3 . events . ifolded . withIndex))+  (mx, changes) <- runWriterT $ shortFoldM x (tails hist) $+    \hs -> \case+      Nothing -> pure Nothing+      Just x' -> handle hs x'+  forM_ mx $ throwError . UnexpectedRemainder+  pure changes++buyOrSell :: Traversal' (Timed Action) Lot+buyOrSell = item . failing _Buy _Sell++wash :: Traversal' (Timed Action) Lot+wash = item . _Wash++opened :: Traversal' (Timed Event) Lot+opened = item . _Opened . _2++handle ::+  MonadError JournalError m =>+  [(Int, Timed Event)] ->+  Timed Action ->+  WriterT+    [Change]+    (ReaderT (Int, Amount 2, InstrumentState) m)+    (Maybe (Timed Action))+handle+  ((n, open@(view item -> Opened buyToOpen _)) : _)+  close@(preview buyOrSell -> Just _)+    | buyToOpen == has (item . _Sell) close =+      closePosition n open close+handle+  ((n, open@(view item -> Opened _ o)) : _)+  washing@(preview wash -> Just _)+    | all+        (\ann -> hasn't _Exempt ann && hasn't _Washed ann)+        (o ^. details),+      (open ^. time) `distance` (washing ^. time) <= 30 =+      washExistingPosition n open washing+-- If a wash sale couldn't be applied to the current history, record it to+-- apply to a future opening.+handle [] act@(preview wash -> Just x) = do+  case x ^? details . traverse . _WashTo of+    Just (name, mres) ->+      Nothing+        <$ tell+          [ SaveWash+              name+              ( ( case mres of+                    Nothing -> x+                    Just (_amount, _price) ->+                      let _symbol = x ^. symbol+                          _details = []+                          _computed = []+                       in Lot {..}+                )+                  <$ act+              ),+            Result (Wash x <$ act)+          ]+    _ -> pure Nothing+-- Otherwise, if there is no history to examine then this buy or sale must+-- open a new position.+handle [] action = do+  mact <- shortFoldM+    action+    (action ^.. buyOrSell . details . traverse . _WashApply)+    $ \(name, _amount) -> \case+      Just (act@(preview buyOrSell -> Just open)) -> do+        sales <-+          lift $+            asks+              ( toListOf+                  ( _3 . washSales+                      . ix name+                      . folded+                      . filtered+                        ( \adj ->+                            (adj ^. time)+                              `distance` (act ^. time) <= 30+                        )+                      . to (\x -> x ^. item . amount * x ^. item . price)+                  )+              )+        let _price = sum sales / _amount+            _symbol = open ^. symbol+            _details = []+            _computed = []+        washNewPosition Lot {..} act+      _ -> pure Nothing+  case mact of+    Just (act@(preview buyOrSell -> Just open)) ->+      Nothing+        <$ tell+          [ AddEvent (Opened (has (item . _Buy) act) open <$ act),+            Result (act & buyOrSell . details <>~ [Position Open])+          ]+    _ ->+      -- If none of the above apply, nothing is done for this action, pass+      -- it through+      pure mact+handle _ x = pure $ Just x++-- | The most common trading activities are either to open a new position, or+-- to close an existing one for a profit or loss. If there is a loss within 30+-- days of the opening, it implies a wash sale adjustment of any preceeding or+-- subsequent openings 30 days before or after.+closePosition ::+  MonadError JournalError m =>+  Int ->+  Timed Event ->+  Timed Action ->+  WriterT [Change] m (Maybe (Timed Action))+closePosition n open close = do+  let (s, d) = (open ^?! opened) `alignLots` (close ^?! buyOrSell)+  forM_ ((,) <$> s ^? _SplitUsed <*> d ^? _SplitUsed) $ \(su, du) -> do+    let pricing x =+          x ^. price+            + sum+              ( x+                  ^.. details+                    . traverse+                    . _Washed+              )+        lotFees = sum (du ^.. fees) + sum (su ^.. fees)+        pl+          | has (item . _Sell) close =+            pricing du - pricing su - lotFees+          | otherwise = pricing su - pricing du - lotFees+        res =+          du & details+            <>~ [ Position Close,+                  if pl < 0+                    then Loss (- pl)+                    else Gain pl+                ]+    tell [Result (close & buyOrSell .~ res)]+    -- After closing at a loss, and if the loss occurs within 30 days+    -- of its corresponding open, and there is another open within 30+    -- days of the loss, close it and re-open so it's repriced by the+    -- wash loss.+    let mayWash = (close ^. time) `distance` (open ^. time) <= 30 && pl < 0+    tell+      [ case s ^? _SplitKept of+          Just k ->+            ReplaceEvent+              n+              ( open & opened+                  .~ if mayWash+                    then k & details <>~ [Exempt]+                    else k+              )+          Nothing -> RemoveEvent n+      ]+    when mayWash $+      tell+        [ Submit ((du & price .~ negate pl) <$ close)+        ]+  pure $ (set buyOrSell ?? close) <$> (d ^? _SplitKept)++-- | If the action is a wash sale adjustment, determine if can be applied to+-- any existing open positions. If not, it is remembered, to be applied at the+-- next opening within 30 days of sale.+washExistingPosition ::+  MonadError JournalError m =>+  Int ->+  Timed Event ->+  Timed Action ->+  WriterT [Change] m (Maybe (Timed Action))+washExistingPosition n open washing =+  assert (washing ^?! wash . amount /= 0) $ do+    let (s, d) = (open ^?! opened) `alignLots` (washing ^?! wash)+    -- Wash failing closes by adding the amount to the cost basis of the+    -- opening transaction.+    tell $+      [ case s ^? _SplitKept of+          Just e ->+            ReplaceEvent n (set opened (e & details <>~ [Exempt]) open)+          Nothing -> RemoveEvent n+      ]+        ++ ( AddEvent+               . (set opened ?? open)+               . (details <>~ [Washed (d ^?! _SplitUsed . price)])+               <$> s ^.. _SplitUsed+           )+        ++ ( Result . (set wash ?? washing)+               . (details .~ [Washed (s ^?! _SplitUsed . price)])+               <$> d ^.. _SplitUsed+           )+    pure $ (set wash ?? washing) <$> (d ^? _SplitKept)++-- | If we are opening a position and there is a pending wash sale within the+-- last 30 days, apply the adjustment to the applicable part of this opening.+washNewPosition ::+  MonadError JournalError m =>+  Lot ->+  Timed Action ->+  WriterT [Change] m (Maybe (Timed Action))+washNewPosition washing open =+  assert (washing ^. amount <= open ^?! buyOrSell . amount) $ do+    let (_s, d) = washing `alignLots` (open ^?! buyOrSell)+    -- We wash failing closes by adding the amount to the cost basis of+    -- the opening transaction. Thus, we generate three instances of+    -- WashLossApplied, but only one OpenPosition.+    tell $+      ( AddEvent+          . Timed (open ^. time)+          . Opened (has (item . _Buy) open)+          . (details <>~ [Washed (washing ^. price)])+          <$> d ^.. _SplitUsed+      )+        ++ ( Result . (set buyOrSell ?? open)+               . ( details+                     <>~ [ Position Open,+                           Washed (washing ^. price)+                         ]+                 )+               <$> d ^.. _SplitUsed+           )+    pure $ (set buyOrSell ?? open) <$> d ^? _SplitKept
+ src/Journal/Parse.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++module Journal.Parse (parseJournal, printJournal) where++import Control.Lens+import Data.Char+import Data.Either+import Data.List (intersperse, sort)+import Data.Maybe (mapMaybe)+import qualified Data.Text as T+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL+import Data.Time+import Data.Void+import GHC.TypeLits+import Journal.Amount+import Journal.Types+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L++type Parser = ParsecT Void Text Identity++skipLineComment' :: Tokens Text -> Parser ()+skipLineComment' prefix =+  string prefix+    *> takeWhileP (Just "character") (\x -> x /= '\n' && x /= '\r')+    *> pure ()++whiteSpace :: Parser ()+whiteSpace = L.space space1 lineCmnt blockCmnt+  where+    lineCmnt = skipLineComment' "|"+    blockCmnt = L.skipBlockComment "/*" "*/"++lexeme :: Parser a -> Parser a+lexeme p = p <* whiteSpace++keyword :: Text -> Parser Text+keyword = lexeme . string++parseJournal :: Parser Journal+parseJournal =+  Journal <$> many (whiteSpace *> parseTimed parseAction) <* eof++parseTimed :: Parser a -> Parser (Timed a)+parseTimed p = do+  _time <- Journal.Parse.parseTime+  _item <- p+  pure Timed {..}++parseAction :: Parser Action+parseAction =+  keyword "buy" *> (Buy <$> parseLot)+    <|> keyword "sell" *> (Sell <$> parseLot)+    <|> keyword "wash" *> (Wash <$> parseLot)+    <|> keyword "deposit" *> (Deposit <$> parseLot)+    <|> keyword "withdraw" *> (Withdraw <$> parseLot)+    <|> keyword "assign" *> (Assign <$> parseLot)+    <|> keyword "expire" *> (Expire <$> parseLot)+    <|> keyword "dividend" *> (Dividend <$> parseLot)++parseLot :: Parser Lot+parseLot = do+  _amount <- parseAmount+  _symbol <- TL.toStrict <$> parseSymbol+  _price <- parseAmount+  _details <- many parseAnnotation+  let _computed = []+  pure $+    Lot {..}+      & details . traverse . failing _Fees _Commission //~ _amount++parseAnnotation :: Parser Annotation+parseAnnotation = do+  keyword "position" *> (Position <$> parseEffect)+    <|> keyword "fees" *> (Fees <$> parseAmount)+    <|> keyword "commission" *> (Commission <$> parseAmount)+    <|> keyword "gain" *> (Gain <$> parseAmount)+    <|> keyword "loss" *> (Loss <$> parseAmount)+    <|> keyword "washed" *> (Washed <$> parseAmount)+    <|> keyword "wash" *> parseWash+    <|> keyword "apply"+      *> (WashApply . TL.toStrict <$> parseSymbol <*> parseAmount)+    <|> keyword "exempt" *> pure Exempt+    <|> keyword "net" *> (Net <$> parseAmount)+    <|> keyword "balance" *> (Balance <$> parseAmount)+    <|> keyword "account" *> (Account <$> parseText)+    <|> keyword "trade" *> (Trade <$> parseText)+    <|> keyword "order" *> (Order <$> parseText)+    <|> keyword "xact" *> (Transaction <$> parseText)+    <|> keyword "meta" *> (Meta <$> parseText <*> parseText)+  where+    parseWash = do+      mres <- optional $ do+        q <- parseAmount+        _ <- char '@' <* whiteSpace+        p <- parseAmount+        pure (q, p)+      _ <- keyword "to"+      sym <- parseSymbol+      pure $ WashTo (TL.toStrict sym) mres+    parseEffect =+      Open <$ keyword "open"+        <|> Close <$ keyword "close"++printJournal :: Journal -> Text+printJournal =+  TL.concat+    . intersperse "\n"+    . map (printTimed printAction)+    . view actions++printTimed :: (a -> Text) -> Timed a -> Text+printTimed printItem t =+  TL.concat $ intersperse " " $+    [ printTime (t ^. time),+      printItem (t ^. item)+    ]++printAction :: Action -> Text+printAction = \case+  Buy lot -> "buy " <> printLot lot+  Sell lot -> "sell " <> printLot lot+  Wash lot -> "wash " <> printLot lot+  Deposit lot -> "deposit " <> printLot lot+  Withdraw lot -> "withdraw " <> printLot lot+  Assign lot -> "assign " <> printLot lot+  Expire lot -> "expire " <> printLot lot+  Dividend lot -> "dividend " <> printLot lot++printLot :: Lot -> Text+printLot lot =+  ( TL.concat $+      intersperse+        " "+        ( [ printAmount 0 (lot ^. amount),+            TL.fromStrict (lot ^. symbol),+            printAmount 4 (lot ^. price)+          ]+            ++ inlineAnns+        )+  )+    <> case separateAnns of+      [] -> ""+      xs ->+        ( TL.concat $+            intersperse "\n  " ("" : xs)+        )+  where+    annotations =+      mapMaybe+        printAnnotation+        (sort (lot ^. details ++ lot ^. computed))+    (inlineAnns, separateAnns) = partitionEithers annotations+    totalAmount n x = printAmount n (totaled lot x)+    printAnnotation = \case+      Position eff -> Just $ Left $ case eff of+        Open -> "open"+        Close -> "close"+      Fees x -> Just $ Left $ "fees " <> totalAmount 2 x+      Commission x -> Just $ Left $ "commission " <> totalAmount 2 x+      Gain x -> Just $ Right $ "gain " <> totalAmount 6 x+      Loss x -> Just $ Right $ "loss " <> totalAmount 6 x+      Washed x -> Just $ Right $ "washed " <> totalAmount 6 x+      WashTo x (Just (q, p)) ->+        Just $ Left $+          "wash "+            <> printAmount 0 q+            <> " @ "+            <> printAmount 4 p+            <> " to "+            <> TL.fromStrict x+      WashTo x Nothing -> Just $ Left $ "wash to " <> TL.fromStrict x+      WashApply x amt ->+        Just $ Left $ "apply " <> TL.fromStrict x <> " " <> printAmount 0 amt+      Exempt -> Just $ Left "exempt"+      Net _x -> Nothing+      Balance _x -> Nothing+      -- Net x -> Right $ "net " <> printAmount 2 (x ^. coerced)+      -- Balance x -> Right $ "balance " <> printAmount 2 (x ^. coerced)+      Account x -> Just $ Left $ "account " <> printText x+      Trade x -> Just $ Left $ "trade " <> printText x+      Order x -> Just $ Left $ "order " <> printText x+      Transaction x -> Just $ Left $ "transaction " <> printText x+      Meta k v -> Just $ Right $ "meta " <> printText k <> " " <> printText v+    printText t+      | T.all isAlphaNum t = TL.fromStrict t+      | otherwise = "\"" <> TL.replace "\"" "\\\"" (TL.fromStrict t) <> "\""++parseText :: Parser T.Text+parseText =+  T.pack+    <$> ( char '"' *> manyTill L.charLiteral (char '"')+            <|> some alphaNumChar+        )++parseTime :: Parser UTCTime+parseTime = do+  dateString <- some (digitChar <|> char '-') <* whiteSpace+  timeString <-+    optional (some (digitChar <|> char ':') <* whiteSpace)+  case timeString of+    Nothing -> parseTimeM False defaultTimeLocale "%Y-%m-%d" dateString+    Just str ->+      parseTimeM+        False+        defaultTimeLocale+        "%Y-%m-%d %H:%M:%S%Q"+        (dateString ++ " " ++ str)++printTime :: UTCTime -> Text+printTime = TL.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q"++parseAmount :: KnownNat n => Parser (Amount n)+parseAmount =+  read <$> some (digitChar <|> char '.') <* whiteSpace++printAmount :: Int -> Amount 6 -> Text+printAmount n = TL.pack . amountToString n++parseSymbol :: Parser Text+parseSymbol =+  TL.pack <$> some (satisfy (\c -> isAlphaNum c || c `elem` ['.', '/']))+    <* whiteSpace
+ src/Journal/Split.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Journal.Split where++import Control.Lens+import Data.Default+import Data.List (foldl')++data Split a+  = Some+      { _used :: a,+        _kept :: a+      }+  | All a+  | None a+  deriving (Eq, Ord, Show)++makePrisms ''Split++instance Functor Split where+  fmap f (Some u k) = Some (f u) (f k)+  fmap f (All u) = All (f u)+  fmap f (None k) = None (f k)++_Splits :: Traversal (Split a) (Split b) a b+_Splits f (Some u k) = Some <$> f u <*> f k+_Splits f (All u) = All <$> f u+_Splits f (None k) = None <$> f k++_SplitUsed :: Traversal' (Split a) a+_SplitUsed f (Some u k) = Some <$> f u <*> pure k+_SplitUsed f (All u) = All <$> f u+_SplitUsed _ (None k) = pure $ None k++_SplitKept :: Traversal' (Split a) a+_SplitKept f (Some u k) = Some u <$> f k+_SplitKept _ (All u) = pure $ All u+_SplitKept f (None k) = None <$> f k++align ::+  (Eq n, Ord n, Num n) =>+  Lens' a n ->+  Lens' b n ->+  a ->+  b ->+  (Split a, Split b)+align la lb x y+  | xq == 0 && yq == 0 =+    (None x, None y)+  | xq == 0 = (None x, All y)+  | yq == 0 = (All x, None y)+  | xq == yq = (All x, All y)+  | xq < yq =+    ( All x,+      Some+        (y & lb .~ xq)+        (y & lb .~ diff)+    )+  | otherwise =+    ( Some+        (x & la .~ yq)+        (x & la .~ diff),+      All y+    )+  where+    xq = x ^. la+    yq = y ^. lb+    diff = abs (xq - yq)++data Applied v a b = Applied+  { _value :: v,+    _src :: Split a,+    _dest :: Split b+  }+  deriving (Eq, Ord, Show)++makeLenses ''Applied++nothingApplied :: Default v => a -> b -> Applied v a b+nothingApplied x y = Applied def (None x) (None y)++splits :: Default v => Split a -> Split b -> Applied v a b+splits = Applied def++data Considered a b c = Considered+  { _fromList :: [a],+    _newList :: [b],+    _fromElement :: [c],+    _newElement :: Maybe c+  }+  deriving (Eq, Show)++makeLenses ''Considered++consideredList :: Traversal' (Considered a a c) a+consideredList f Considered {..} =+  Considered <$> traverse f _fromList+    <*> traverse f _newList+    <*> pure _fromElement+    <*> pure _newElement++consideredElements :: Traversal' (Considered a b c) c+consideredElements f Considered {..} =+  Considered _fromList _newList+    <$> traverse f _fromElement+    <*> traverse f _newElement++consideredFrom :: Traversal' (Considered a b a) a+consideredFrom f Considered {..} =+  Considered <$> traverse f _fromList+    <*> pure _newList+    <*> traverse f _fromElement+    <*> pure _newElement++consideredNew :: Traversal' (Considered a c c) c+consideredNew f Considered {..} =+  Considered _fromList+    <$> traverse f _newList+    <*> pure _fromElement+    <*> traverse f _newElement++newConsidered :: Considered a b c+newConsidered =+  Considered+    { _fromList = [],+      _newList = [],+      _fromElement = [],+      _newElement = Nothing+    }++-- Given a list, and an element, determine the following three data:+--+-- - A revised version of the input list, based on that element+-- - Elements derived from the input list that become new outputs+-- - The fragments of the original element+consider ::+  (b -> c -> Applied v b c) ->+  (c -> v -> b -> a) ->+  [b] ->+  c ->+  Considered a b c+consider f mk lst el =+  result & fromList %~ reverse+    & newList %~ reverse+    & fromElement %~ reverse+    & newElement .~ remaining+  where+    (remaining, result) = foldl' go (Just el, newConsidered) lst+    go (Nothing, c) x = (Nothing, c & newList %~ (x :))+    go (Just z, c) x =+      ( _dest ^? _SplitKept,+        c & fromList %~ maybe id ((:) . mk z _value) (_src ^? _SplitUsed)+          & newList %~ maybe id (:) (_src ^? _SplitKept)+          & fromElement %~ maybe id (:) (_dest ^? _SplitUsed)+      )+      where+        Applied {..} = f x z
+ src/Journal/ThinkOrSwim.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Journal.ThinkOrSwim where++import Control.Lens+import Control.Monad.State+import qualified Data.ByteString as B+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BL+import qualified Data.Csv as Csv+import Data.Map (Map)+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+-- import Data.Time+import Data.Vector (toList)+-- import Journal.Amount+import System.IO++data ThinkOrSwim = ThinkOrSwim+  { _account :: Text,+    _xacts :: [Csv.NamedRecord],+    _futures :: [Csv.NamedRecord],+    _forex :: [Csv.NamedRecord],+    _orders :: [Csv.NamedRecord],+    _trades :: [Csv.NamedRecord],+    _equities :: [Csv.NamedRecord],+    _options :: [Csv.NamedRecord],+    _pandl :: [Csv.NamedRecord],+    _byOrderId ::+      Map+        B.ByteString+        ([Csv.NamedRecord], [Csv.NamedRecord], [Csv.NamedRecord])+  }++makeLenses ''ThinkOrSwim++readSection :: Handle -> IO [Csv.NamedRecord]+readSection h =+  fmap (toList . snd)+    . check+    . Csv.decodeByNameWithP pure Csv.defaultDecodeOptions+    =<< readUntilBlank+  where+    readUntilBlank = do+      line <- BL.fromStrict <$> B.hGetLine h+      if BL.null line+        then pure line+        else do+          rest <- readUntilBlank+          pure $ line <> "\n" <> rest+    check :: MonadFail m => Either String a -> m a+    check (Left err) = fail $ "Error: " ++ err+    check (Right res) = pure res++readCsv :: FilePath -> IO ThinkOrSwim+readCsv path = withFile path ReadMode $ \h -> do+  "\65279Account" : "Statement" : "for" : _account : _ <-+    TL.words . TL.decodeUtf8 <$> readLine h+  "" <- readLine h+  "Cash Balance" <- readLine h+  _xacts <- readSection h+  "Futures Statements" <- readLine h+  _futures <- readSection h+  "Forex Statements" <- readLine h+  _forex <- readSection h+  " " <- readLine h+  "\"Total" : "Cash" : _ <-+    TL.words . TL.decodeUtf8 <$> readLine h+  "" <- readLine h+  "" <- readLine h+  "Account Order History" <- readLine h+  _orders <- readSection h+  "Account Trade History" <- readLine h+  _trades <- readSection h+  "Equities" <- readLine h+  _equities <- readSection h+  "Options" <- readLine h+  _options <- readSection h+  "Profits and Losses" <- readLine h+  _pandl <- readSection h+  let _byOrderId = flip execState mempty $ do+        forM_ _xacts $ \xact -> do+          entry (xact ^?! ix "REF #") . _1 <>= [xact]+        scanOrders _2 _orders+        scanOrders _3 _trades+  pure ThinkOrSwim {..}+  where+    entry oid = at oid . non ([], [], [])+    scanOrders l = flip foldM_ Nothing $ \lx x -> do+      let oid = x ^?! ix "Order ID"+      entry+        ( case lx of+            Nothing -> oid+            Just o+              | B.null oid -> o+              | otherwise -> oid+        )+        . l+        <>= [x]+      pure $+        if null x+          then lx+          else Just oid+    readLine :: Handle -> IO ByteString+    readLine h = do+      line <- BL.fromStrict <$> B.hGetLine h+      -- print line+      pure line
+ src/Journal/Types.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Journal.Types where++import Control.Applicative+import Control.Lens+import Data.IntMap (IntMap)+import Data.Map (Map)+import Data.Text (Text)+import Data.Time+import Data.Time.Format.ISO8601+import GHC.Generics hiding (to)+import GHC.TypeLits+import Journal.Amount+import Journal.Split+import Text.Show.Pretty+import Prelude hiding (Double, Float)++data Effect = Open | Close+  deriving (Show, Eq, Ord, Enum, Bounded, Generic, PrettyVal)++data Annotation+  = Position Effect+  | Fees (Amount 6)+  | Commission (Amount 6)+  | Gain (Amount 6)+  | Loss (Amount 6)+  | Washed (Amount 6)+  | WashTo Text (Maybe (Amount 6, Amount 6))+  | WashApply Text (Amount 6)+  | Exempt+  | Net (Amount 2)+  | Balance (Amount 2)+  | Account Text+  | Trade Text+  | Order Text+  | Transaction Text+  | Meta Text Text+  deriving (Show, Eq, Ord, Generic, PrettyVal)++makePrisms ''Annotation++-- | The '_Adjustments' traversal returns any adjust to the price of an+-- action. For example, a prior wash sale may increase the cost basis of a+-- position, or a gain might decrease it.+adjustment :: Traversal' Annotation (Amount 6)+adjustment f = \case+  Fees x -> Fees <$> f x+  Commission x -> Commission <$> f x+  Gain x -> Gain . negate <$> f (- x)+  Loss x -> Loss <$> f x+  Washed x -> Washed <$> f x+  x -> x <$ f 0++instance PrettyVal UTCTime where+  prettyVal = String . iso8601Show++-- | A 'Lot' represents a collection of shares, with a given price and a+--   transaction date.+data Lot = Lot+  { _amount :: Amount 6,+    _symbol :: Text,+    _price :: Amount 6,+    -- | All annotations that relate to lot shares are expressed "per share",+    -- just like the price.+    _details :: [Annotation],+    _computed :: [Annotation]+  }+  deriving (Show, Eq, Ord, Generic, PrettyVal)++makeLenses ''Lot++alignLots :: Lot -> Lot -> (Split Lot, Split Lot)+alignLots = align amount amount++totaled :: KnownNat n => Lot -> Amount n -> Amount n+totaled lot n = lot ^. amount . coerced * n++fees :: Traversal' Lot (Amount 6)+fees = details . traverse . failing _Fees _Commission++-- | The '_Adjustments' traversal returns any adjust to the price of an+-- action. For example, a prior wash sale may increase the cost basis of a+-- position, or a gain might decrease it.+adjustments :: Fold Lot (Amount 6)+adjustments f s =+  error "Never used"+    <$ traverse+      f+      ( s ^.. details . traverse . adjustment+          ++ s ^.. computed . traverse . adjustment+      )++data Action+  = Buy Lot+  | Sell Lot+  | Wash Lot+  | Deposit Lot+  | Withdraw Lot+  | Assign Lot+  | Expire Lot+  | Dividend Lot+  deriving+    ( Show,+      Eq,+      Ord,+      Generic,+      PrettyVal+    )++makePrisms ''Action++foldAction :: (Lot -> a) -> Action -> a+foldAction f = \case+  Buy lot -> f lot+  Sell lot -> f lot+  Wash lot -> f lot+  Deposit lot -> f lot+  Withdraw lot -> f lot+  Assign lot -> f lot+  Expire lot -> f lot+  Dividend lot -> f lot++mapAction :: (Lot -> Lot) -> Action -> Action+mapAction f = \case+  Buy lot -> Buy (f lot)+  Sell lot -> Sell (f lot)+  Wash lot -> Wash (f lot)+  Deposit lot -> Deposit (f lot)+  Withdraw lot -> Withdraw (f lot)+  Assign lot -> Assign (f lot)+  Expire lot -> Expire (f lot)+  Dividend lot -> Dividend (f lot)++_Lot :: Lens' Action Lot+_Lot f = \case+  Buy lot -> Buy <$> f lot+  Sell lot -> Sell <$> f lot+  Wash lot -> Wash <$> f lot+  Deposit lot -> Deposit <$> f lot+  Withdraw lot -> Withdraw <$> f lot+  Assign lot -> Assign <$> f lot+  Expire lot -> Expire <$> f lot+  Dividend lot -> Dividend <$> f lot++lotNetAmount :: Lot -> Amount 6+lotNetAmount lot = totaled lot (lot ^. price + sum (lot ^.. adjustments))++-- | The 'netAmount' indicates the exact effect on account balance this action+-- represents.+netAmount :: Action -> Amount 2+netAmount = view coerced . \case+  Buy lot -> - totaled lot (lot ^. price + sum (lot ^.. fees))+  Sell lot -> totaled lot (lot ^. price - sum (lot ^.. fees))+  Wash _lot -> 0+  Deposit lot -> lot ^. amount+  Withdraw lot -> - (lot ^. amount)+  Assign _lot -> 0+  Expire _lot -> 0+  Dividend lot -> lot ^. amount++data Event+  = Opened Bool Lot+  deriving+    ( Show,+      Eq,+      Ord,+      Generic,+      PrettyVal+    )++makePrisms ''Event++data Timed a = Timed+  { _time :: UTCTime,+    _item :: a+  }+  deriving+    ( Show,+      Eq,+      Ord,+      Generic,+      PrettyVal,+      Functor,+      Foldable,+      Traversable+    )++makeLenses ''Timed++data Change+  = SawAction (Timed Action)+  | Submit (Timed Lot) -- can only be an adjustment+  | SubmitEnd+  | Result (Timed Action)+  | AddEvent (Timed Event)+  | RemoveEvent Int+  | ReplaceEvent Int (Timed Event)+  | SaveWash Text (Timed Lot)+  deriving+    ( Show,+      Eq,+      Ord,+      Generic,+      PrettyVal+    )++makePrisms ''Change++data InstrumentState = InstrumentState+  { _events :: IntMap (Timed Event),+    _washSales :: Map Text [Timed Lot]+  }+  deriving+    ( Show,+      Eq,+      Ord,+      Generic+    )++makeLenses ''InstrumentState++newInstrumentState :: InstrumentState+newInstrumentState = InstrumentState mempty mempty++data AccountState = AccountState+  { _nextId :: Int,+    _balance :: Amount 2,+    _instruments :: Map Text InstrumentState+  }+  deriving+    ( Show,+      Eq,+      Ord,+      Generic+    )++makeLenses ''AccountState++newAccountState :: AccountState+newAccountState = AccountState 1 0 mempty++data JournalState = JournalState+  { _accounts :: Map (Maybe Text) AccountState+  }+  deriving+    ( Show,+      Eq,+      Ord,+      Generic+    )++makeLenses ''JournalState++newJournalState :: JournalState+newJournalState = JournalState mempty++data Journal = Journal+  { _actions :: [Timed Action]+  }+  deriving+    ( Show,+      Eq,+      Ord,+      Generic,+      PrettyVal+    )++makeLenses ''Journal++newJournal :: Journal+newJournal = Journal []++data JournalError+  = ChangeNotFromImpliedChanges Change+  | UnexpectedRemainder (Timed Action)+  | NetAmountDoesNotMatch (Timed Action) (Amount 2) (Amount 2)+  | BalanceDoesNotMatch (Timed Action) (Amount 2) (Amount 2)+  deriving+    ( Show,+      Eq,+      Ord,+      Generic,+      PrettyVal+    )++-- "Change not produced by impliedChanges"+-- "impliedChanges: unexpected remainder: "+-- "Unapplied wash sale requires use of \"wash to\""
+ src/Journal/Utils.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++module Journal.Utils where++import Control.Applicative+import Control.Arrow+import Control.Lens+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State+import Data.Coerce+import Data.Foldable+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time+import Data.Time.Format.ISO8601+import Debug.Trace (traceM)+import Text.PrettyPrint as P+import Prelude hiding ((<>), Double, Float)++readonly :: Monad m => ReaderT s m a -> StateT s m a+readonly f = lift . runReaderT f =<< get++justify :: [a] -> [Maybe a]+justify [] = [Nothing]+justify (x : xs) = Just x : justify xs++unzipBoth :: [([a], [b])] -> ([a], [b])+unzipBoth = (concat *** concat) . unzip++distance :: UTCTime -> UTCTime -> Integer+distance x y = abs (utctDay x `diffDays` utctDay y)++renderM :: Applicative f => Doc -> f ()+renderM = traceM . render++percent :: (Num a, Num b, Coercible b a) => a -> Lens' b b+percent n f s = f part <&> \v -> v + (s - part)+  where+    part = s * coerce n++zipped :: Traversal' s a -> Traversal' s b -> Traversal' s (a, b)+zipped f g k s = case liftA2 (,) (s ^? f) (s ^? g) of+  Nothing -> pure s+  Just p -> k p <&> \(a, b) -> s & f .~ a & g .~ b++zipped3 ::+  Traversal' s a ->+  Traversal' s b ->+  Traversal' s c ->+  Traversal' s (a, b, c)+zipped3 f g h k s = case liftA3 (,,) (s ^? f) (s ^? g) (s ^? h) of+  Nothing -> pure s+  Just p -> k p <&> \(a, b, c) -> s & f .~ a & g .~ b & h .~ c++contractList :: (a -> a -> Maybe a) -> [a] -> [a]+contractList _ [] = []+contractList _ [x] = [x]+contractList f (x : y : xs) = case f x y of+  Nothing -> x : contractList f (y : xs)+  Just z -> contractList f (z : xs)++renderList :: (a -> Doc) -> [a] -> Doc+renderList _ [] = brackets P.empty+renderList f ts =+  fst (foldl' go (P.empty, True) ts) <> space <> rbrack+  where+    go (_, True) x = (lbrack <> space <> f x, False)+    go (acc, False) x = (acc $$ comma <> space <> f x, False)++class Render a where+  rendered :: a -> Doc++instance Render a => Render [a] where+  rendered = renderList rendered++instance Render a => Render (Maybe a) where+  rendered Nothing = text "Nothing"+  rendered (Just x) = text "Just" <> space <> rendered x++instance Render Text where+  rendered = text . T.unpack++instance Render Day where+  rendered = text . iso8601Show++instance Render UTCTime where+  rendered = text . iso8601Show . utctDay++tshow :: Show a => a -> Doc+tshow = text . show++-- A Fold over the individual components of a Text split on a separator.+--+-- splitOn :: Text -> Fold String String+-- splitOn :: Text -> Traversal' String String+--+-- splitOn :: Text -> IndexedFold Int String String+-- splitOn :: Text -> IndexedTraversal' Int String String+--+-- Note: This function type-checks as a Traversal but it doesn't satisfy the+-- laws. It's only valid to use it when you don't insert any separator strings+-- while traversing, and if your original Text contains only isolated split+-- strings.+splitOn :: Applicative f => Text -> IndexedLensLike' Int f Text Text+splitOn s f = fmap (T.intercalate s) . go . T.splitOn s+  where+    go = conjoined traverse (indexing traverse) f
+ src/Journal/mpfr_printf.c view
@@ -0,0 +1,95 @@+#include <stdlib.h>+#include <string.h>+#include <stdio.h>++#include <mpfr.h>++int stream_out_mpq(+  mpq_t      quant,+  size_t     precision,+  int        zeros_prec /* = -1 */,+  mpfr_rnd_t rnd /* = GMP_RNDN */,+  char **    bufPtr)+{+  static const size_t extend_by_digits = 6U;++  mpfr_t tempfb;+  mpfr_t tempfnum;+  mpfr_t tempfden;++  mpfr_init(tempfb);+  mpfr_init(tempfnum);+  mpfr_init(tempfden);++  // Convert the rational number to a floating-point, extending the+  // floating-point to a large enough size to get a precise answer.++  mp_prec_t num_prec =+    (mpfr_prec_t)mpz_sizeinbase(mpq_numref(quant), 2);+  num_prec += extend_by_digits*64;+  if (num_prec < MPFR_PREC_MIN)+    num_prec = MPFR_PREC_MIN;++  mpfr_set_prec(tempfnum, num_prec);+  mpfr_set_z(tempfnum, mpq_numref(quant), rnd);++  mp_prec_t den_prec =+    (mpfr_prec_t)mpz_sizeinbase(mpq_denref(quant), 2);+  den_prec += extend_by_digits*64;+  if (den_prec < MPFR_PREC_MIN)+    den_prec = MPFR_PREC_MIN;++  mpfr_set_prec(tempfden, den_prec);+  mpfr_set_z(tempfden, mpq_denref(quant), rnd);++  mpfr_set_prec(tempfb, num_prec + den_prec);+  mpfr_div(tempfb, tempfnum, tempfden, rnd);++  if (mpfr_asprintf(bufPtr, "%.*RNf", precision, tempfb) < 0) {+    mpfr_clear(tempfb);+    mpfr_clear(tempfnum);+    mpfr_clear(tempfden);+    return -1;+  }++  char * buf = *bufPtr;++  if (zeros_prec >= 0) {+    size_t index = strlen(buf);+    size_t point = 0;+    for (size_t i = 0; i < index; i++) {+      if (buf[i] == '.') {+        point = i;+        break;+      }+    }+    if (point > 0) {+      while (--index >= (point + 1 + (size_t)zeros_prec) &&+             buf[index] == '0')+        buf[index] = '\0';+      if (index >= (point + (size_t)zeros_prec) &&+          buf[index] == '.')+        buf[index] = '\0';+    }+  }++  mpfr_clear(tempfb);+  mpfr_clear(tempfnum);+  mpfr_clear(tempfden);++  return 0;+}++void rational_to_str(+  signed long num,+  unsigned long den,+  unsigned int rnd_mode,+  size_t prec,+  char ** bufPtr)+{+  mpq_t val;+  mpq_init(val);+  mpq_set_si(val, num, den);+  stream_out_mpq(val, prec, -1, rnd_mode, bufPtr);+  mpq_clear(val);+}
+ test/Examples.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Examples (testExamples) where++import Data.List (intersperse)+import Data.String.Here.Interpolated+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL+import Journal.Model+import Journal.Parse+import Test.Tasty+import Test.Tasty.HUnit+import Text.Megaparsec++testExamples :: TestTree+testExamples =+  testGroup+    "examples"+    [ baseline,+      realWorld+    ]++baseline :: TestTree+baseline =+  testGroup+    "baseline"+    [ testCase "journal-buy-sell-profit" journalBuySellProfit,+      testCase "journal-buy-sell-loss-buy" journalBuySellLossBuy+    ]++journalBuySellProfit :: Assertion+journalBuySellProfit = ii @--> oo+  where+    ii =+      [i|+2020-07-02 buy 100 AAPL 260.00+2020-07-03 sell 100 AAPL 300.00 fees 0.20+        |]+    oo =+      [i|+2020-07-02 00:00:00 buy 100 AAPL 260.0000 open+2020-07-03 00:00:00 sell 100 AAPL 300.0000 close fees 0.20+  gain 3999.800000+        |]++journalBuySellLossBuy :: Assertion+journalBuySellLossBuy = ii @--> oo+  where+    ii =+      [i|+2020-07-02 buy 100 AAPL 260.00+2020-07-03 sell 100 AAPL 240.00 fees 0.20 wash to A+2020-07-04 buy 100 AAPL 260.00 apply A 100+        |]+    oo =+      [i|+2020-07-02 00:00:00 buy 100 AAPL 260.0000 open+2020-07-03 00:00:00 sell 100 AAPL 240.0000 close fees 0.20 wash to A+  loss 2000.200000+2020-07-03 00:00:00 wash 100 AAPL 20.0020 fees 0.20 wash to A+2020-07-04 00:00:00 buy 100 AAPL 260.0000 open apply A 100+  washed 2000.200000+        |]++realWorld :: TestTree+realWorld =+  testGroup+    "real-world"+    [ testCase "zoom-history" zoomHistory+    ]++zoomHistory :: Assertion+zoomHistory = ii @--> oo+  where+    ii =+      [i|+| Trns |   Qty | Open  |    Basis |    Price | Gain ($) |    |                     |+|------+-------+-------+----------+----------+----------+----+---------------------|+| Eqty |   140 | 06/24 |  99.7792 |          |          |    |                     |+| Eqty |    10 | 06/24 |   89.785 |          |          |    |                     |+| Eqty |    30 | 06/24 |   106.68 |          |          |    |                     |+| Eqty |   170 | 06/25 |  85.8415 |          |          |    |                     |++2019-06-24 buy 140 ZM 99.7792 exempt+2019-06-24 buy 10 ZM 89.785 exempt+2019-06-24 buy 30 ZM 106.68 exempt+2019-06-25 buy 170 ZM 85.8415 exempt++2019-07-01 buy 50 ZM 85.80+| Buy  |    50 |       |          |    85.80 |          |    |                     |++2019-07-01 sell 50 ZM 86.675 fees 0.10+| Sell |    50 | 06/24 |  99.7792 |   86.673 |  -655.31 |    |                     |+| Wash |  [50] | 07/01 |          |          |   655.31 | == | 85.80 -> 98.9062    |++2019-07-02 buy 50 ZM 85.50+| Buy  |    50 |       |          |    85.50 |          |    |                     |++2019-07-03 sell 100 ZM 86.7765 fees 0.19 wash to A+| Sell |    90 | 06/24 |  99.7792 |  86.7746 | -1170.42 |    |                     |+| Wash |  [50] | 07/02 |          |          |   650.23 | == | 85.50 -> 98.5046    |+| Wash |  [40] | 07/29 |          |          |   520.19 | A. |                     |+| Sell |    10 | 06/24 |   89.785 |   86.775 |   -30.10 |    |                     |+| Wash |  [10] | 07/29 |          |          |    30.10 | A. |                     |++2019-07-03 sell 100 ZM 88.14 fees 0.20 wash to A+| Sell |    30 | 06/24 |   106.68 |   88.138 |  -556.26 |    |                     |+| Wash |  [30] | 07/29 |          |          |   556.26 | A> | 95.7852 -> 98.5516  |+| Sell |    70 | 06/25 |  85.8415 |  88.1381 |   160.76 |    |                     |++2019-07-12 sell 200 ZM 94.085 fees 0.41 wash to B+| Sell |   100 | 06/25 |  85.8415 |   94.083 |   824.15 |    |                     |+| Sell |    50 | 07/01 |  98.9062 |  94.0828 |  -241.17 |    |                     |+| Sell |    50 | 07/02 |  98.5046 |   94.083 |  -221.08 |    |                     |+| Wash |  [50] | 07/29 |          |          |   241.17 | B. |                     |+| Wash |  [50] | 07/29 |          |          |   221.08 | B> | 95.7852 -> 100.4077 |++2019-07-29 buy 500 ZM 95.7852 apply A 400 apply B 100+| Buy  |   400 |       |          |  98.5516 |          | <A |                     |+| Buy  |   100 |       |          | 100.4077 |          | <B |                     |++2019-07-29 sell 400 ZM 95.657 fees 0.84 wash 200 @ 0.1303 to C+| Sell |   400 | 07/29 |  98.5516 |  95.6549 | -1158.67 |    |                     |+| Wash | [200] | 07/30 |          |          |    26.06 | C> | 96.00 -> 96.1303    |++2019-07-29 sell 100 ZM 96.1841 fees 0.21+| Sell |   100 | 07/29 | 100.4077 |   96.182 |  -422.57 |    |                     |++2019-07-30 buy 200 ZM 96.00 apply C 200+| Buy  |   200 |       |          |  96.1303 |          | <C |                     |+2019-09-06 buy 100 ZM 85.97 commission 5.00+| Buy  |   100 |       |          |    86.02 |          |    |                     |++2020-02-18 sell 300 ZM 95.00 fees 0.67+| Sell |   200 | 07/30 | 96.1303  |   95.00  |   897.78 |    |                     |+| Sell |   100 | 09/06 | 85.9245  |   95.00  |  -226.51 |    |                     |+        |]+    oo =+      [i|+2019-06-24 00:00:00 buy 140 ZM 99.7792 open exempt+2019-06-24 00:00:00 buy 10 ZM 89.7850 open exempt+2019-06-24 00:00:00 buy 30 ZM 106.6800 open exempt+2019-06-25 00:00:00 buy 170 ZM 85.8415 open exempt+2019-07-01 00:00:00 buy 50 ZM 85.8000 open+2019-07-01 00:00:00 sell 50 ZM 86.6750 close fees 0.10+  loss 655.310000+2019-07-01 00:00:00 wash 50 ZM 13.1062+  washed 4290.000000+2019-07-02 00:00:00 buy 50 ZM 85.5000 open+2019-07-03 00:00:00 sell 90 ZM 86.7765 close fees 0.171 wash to A+  loss 1170.414000+2019-07-03 00:00:00 wash 50 ZM 13.0046+  washed 4275.000000+2019-07-03 00:00:00 wash 40 ZM 13.0046 fees 0.076 wash to A+2019-07-03 00:00:00 sell 10 ZM 86.7765 close fees 0.019 wash to A+  loss 30.104000+2019-07-03 00:00:00 wash 10 ZM 3.0104 fees 0.019 wash to A+2019-07-03 00:00:00 sell 30 ZM 88.1400 close fees 0.06 wash to A+  loss 556.260000+2019-07-03 00:00:00 wash 30 ZM 18.5420 fees 0.06 wash to A+2019-07-03 00:00:00 sell 70 ZM 88.1400 close fees 0.14 wash to A+  gain 160.755000+2019-07-12 00:00:00 sell 100 ZM 94.0850 close fees 0.205 wash to B+  gain 824.145000+2019-07-12 00:00:00 sell 50 ZM 94.0850 close fees 0.1025 wash to B+  loss 241.162500+2019-07-12 00:00:00 wash 50 ZM 4.82325 fees 0.1025 wash to B+2019-07-12 00:00:00 sell 50 ZM 94.0850 close fees 0.1025 wash to B+  loss 221.082500+2019-07-12 00:00:00 wash 50 ZM 4.42165 fees 0.1025 wash to B+2019-07-29 00:00:00 buy 400 ZM 95.7852 open apply A 400 apply B 100+  washed 1106.548000+2019-07-29 00:00:00 buy 100 ZM 95.7852 open apply A 400 apply B 100+  washed 462.245000+2019-07-29 00:00:00 sell 400 ZM 95.6570 close fees 0.84 wash 200 @ 0.1303 to C+  loss 1158.668000+2019-07-29 00:00:00 wash 400 ZM 2.89667 fees 0.84 wash 200 @ 0.1303 to C+2019-07-29 00:00:00 sell 100 ZM 96.1841 close fees 0.21+  loss 422.565000+2019-07-30 00:00:00 buy 200 ZM 96.0000 open apply C 200+  washed 26.060000+2019-09-06 00:00:00 buy 100 ZM 85.9700 open commission 5.00+2020-02-18 00:00:00 sell 200 ZM 95.0000 close fees 0.446667+  loss 226.506667+2020-02-18 00:00:00 sell 100 ZM 95.0000 close fees 0.223333+  gain 897.776667+        |]++(@-->) :: Text -> Text -> Assertion+x @--> y = do+  y' <- parseProcessPrint "" x+  trimLines y' @?= trimLines y+  where+    trimLines =+      TL.concat+        . intersperse "\n"+        . map TL.strip+        . TL.splitOn "\n"+        . TL.strip+    parseProcessPrint :: MonadFail m => FilePath -> Text -> m Text+    parseProcessPrint path journal = do+      actions <- case parse parseJournal path journal of+        Left e -> fail $ errorBundlePretty e+        Right res -> pure res+      case processJournal actions of+        Left err ->+          error $ "Error processing journal " ++ path ++ ": " ++ show err+        Right j -> pure $ printJournal j
+ test/Main.hs view
@@ -0,0 +1,14 @@+module Main where++import Examples+import ModelTests+import Test.Tasty++main :: IO ()+main =+  defaultMain $+    testGroup+      "trade-journal"+      [ testExamples,+        testModel+      ]
+ test/ModelTests.hs view
@@ -0,0 +1,427 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module ModelTests (testModel) where++import Control.Exception+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Int+import Data.Ratio+import Data.Time+import Data.Typeable+import Hedgehog hiding (Action)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Journal.Amount+import Journal.Model+import Journal.Types+import Test.HUnit.Lang (FailureReason (..))+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Hedgehog+import Text.Show.Pretty++data MockFailure = MockFailure FailureReason+  deriving (Eq, Typeable)++instance Show MockFailure where+  show (MockFailure (Reason msg)) = msg+  show (MockFailure (ExpectedButGot preface expected actual)) = msg+    where+      msg =+        (case preface of Just str -> str ++ "\n"; Nothing -> "")+          ++ "expected:\n"+          ++ expected+          ++ "\n but got:\n"+          ++ actual++instance Exception MockFailure++assertEqual' ::+  (Eq a, PrettyVal a, HasCallStack) =>+  -- | The message prefix+  String ->+  -- | The expected value+  a ->+  -- | The actual value+  a ->+  Assertion+assertEqual' preface expected actual =+  unless (actual == expected) $ do+    throwIO+      ( MockFailure+          ( ExpectedButGot+              ( if Prelude.null preface+                  then Nothing+                  else Just preface+              )+              (dumpStr expected)+              (dumpStr actual)+          )+      )++infix 1 @?==++(@?==) :: (MonadIO m, Eq a, PrettyVal a, HasCallStack) => a -> a -> m ()+actual @?== expected = liftIO $ assertEqual' "" expected actual++testModel :: TestTree+testModel =+  testGroup+    "model"+    [ baseline+    ]++genUTCTime :: MonadGen m => m UTCTime+genUTCTime = do+  y <- toInteger <$> Gen.int (Range.constant 2000 2019)+  m <- Gen.int (Range.constant 1 12)+  d <- Gen.int (Range.constant 1 28)+  let day = fromGregorian y m d+  secs <- toInteger <$> Gen.int (Range.constant 0 86401)+  pure $ UTCTime day (secondsToDiffTime secs)++genAmount :: MonadGen m => Range Int64 -> m (Amount n)+genAmount range = do+  d <- Gen.integral range+  n <- Gen.integral range+  pure $ Amount (d % n)++genTimed :: MonadGen m => m a -> m (Timed a)+genTimed gen = do+  _time <- genUTCTime+  _item <- gen+  pure Timed {..}++genLot :: MonadGen m => m Lot+genLot = do+  q <- genAmount (Range.linear 1 1000)+  p <- genAmount (Range.linear 1 2000)+  pure $ Lot q "FOO" p [] []++baseline :: TestTree+baseline =+  testGroup+    "baseline"+    [ testProperty "simple-buy" simpleBuy,+      testProperty "buy-buy" buyBuy,+      testProperty "buy-sell-breakeven" buySellBreakeven,+      testProperty "buy-sell-profit" buySellProfit,+      testProperty "buy-sell-part-profit" buySellPartProfit,+      testProperty "buy-buy-sell-loss" buyBuySellLoss,+      testProperty "buy-sell-loss-buy" buySellLossBuy,+      testProperty "buy-sell-loss" buySellLoss,+      testProperty "simple-sell" simpleSell,+      testProperty "sell-buy-profit" sellBuyProfit+    ]++simpleBuy :: Property+simpleBuy = property $ do+  b <- forAll $ genTimed genLot+  -- A simple buy+  lift $+    processActionsWithChanges+      [Buy <$> b]+      @?== Right+        ( [ SawAction (Buy <$> b),+            AddEvent (Opened True <$> b),+            Result (Buy <$> (b & item . details <>~ [Position Open]))+          ],+          [Buy <$> (b & item . details <>~ [Position Open])]+        )++buyBuy :: Property+buyBuy = property $ do+  b <- forAll $ genTimed genLot+  lift $+    processActionsWithChanges+      [ Buy <$> b,+        Buy <$> b+      ]+      @?== Right+        ( [ SawAction (Buy <$> b),+            AddEvent (Opened True <$> b),+            Result (Buy <$> (b & item . details <>~ [Position Open])),+            SawAction (Buy <$> b),+            AddEvent (Opened True <$> b),+            Result (Buy <$> (b & item . details <>~ [Position Open]))+          ],+          [ Buy <$> (b & item . details <>~ [Position Open]),+            Buy <$> (b & item . details <>~ [Position Open])+          ]+        )++buySellBreakeven :: Property+buySellBreakeven = property $ do+  b <- forAll $ genTimed genLot+  -- A buy and sell at break-even+  lift $+    processActionsWithChanges+      [ Buy <$> b,+        Sell <$> b+      ]+      @?== Right+        ( [ SawAction (Buy <$> b),+            AddEvent (Opened True <$> b),+            Result (Buy <$> (b & item . details <>~ [Position Open])),+            SawAction (Sell <$> b),+            Result+              ( Sell+                  <$> (b & item . details <>~ [Position Close, Gain 0])+              ),+            RemoveEvent 1+          ],+          [ Buy <$> (b & item . details <>~ [Position Open]),+            Sell <$> (b & item . details <>~ [Position Close, Gain 0])+          ]+        )++buySellProfit :: Property+buySellProfit = property $ do+  b <- forAll $ genTimed genLot+  let s = b+      sp = s & item . price +~ 10+  -- A buy and sell at a profit+  lift $+    processActionsWithChanges+      [ Buy <$> b,+        Sell <$> sp+      ]+      @?== Right+        ( [ SawAction (Buy <$> b),+            AddEvent (Opened True <$> b),+            Result (Buy <$> (b & item . details <>~ [Position Open])),+            SawAction (Sell <$> sp),+            Result+              ( Sell+                  <$> (sp & item . details <>~ [Position Close, Gain 10])+              ),+            RemoveEvent 1+          ],+          [ Buy <$> (b & item . details <>~ [Position Open]),+            Sell <$> (sp & item . details <>~ [Position Close, Gain 10])+          ]+        )++buySellPartProfit :: Property+buySellPartProfit = property $ do+  b <- forAll $ genTimed genLot+  let b2 = b & item . amount *~ 2+      s = b+      sp = s & item . price +~ 10+  -- A buy and sell at a partial profit+  lift $+    processActionsWithChanges+      [ Buy <$> b2,+        Sell <$> sp+      ]+      @?== Right+        ( [ SawAction (Buy <$> b2),+            AddEvent (Opened True <$> b2),+            Result (Buy <$> (b2 & item . details <>~ [Position Open])),+            SawAction (Sell <$> sp),+            Result+              ( Sell+                  <$> (sp & item . details <>~ [Position Close, Gain 10])+              ),+            ReplaceEvent 1 (Opened True <$> b)+          ],+          [ Buy <$> (b2 & item . details <>~ [Position Open]),+            Sell <$> (sp & item . details <>~ [Position Close, Gain 10])+          ]+        )++buySellLoss :: Property+buySellLoss = property $ do+  b <- forAll $ genTimed genLot+  let s = b+      sl =+        s & item . price -~ 1+  -- A buy and sell at a loss+  lift $+    processActionsWithChanges+      [ Buy <$> b,+        Sell <$> sl+      ]+      @?== Right+        ( [ SawAction (Buy <$> b),+            AddEvent (Opened True <$> b),+            Result (Buy <$> (b & item . details <>~ [Position Open])),+            SawAction (Sell <$> sl),+            Result+              ( Sell+                  <$> ( sl & item . details+                          <>~ [Position Close, Loss 1]+                      )+              ),+            RemoveEvent 1,+            Submit (sl & item . price .~ 1),+            SubmitEnd+          ],+          [ Buy <$> (b & item . details <>~ [Position Open]),+            Sell <$> (sl & item . details <>~ [Position Close, Loss 1])+          ]+        )++buySellLossBuy :: Property+buySellLossBuy = property $ do+  b <- forAll $ genTimed genLot+  let s = b+      sl =+        s & item . price -~ 1+          & item . details <>~ [WashTo "A" Nothing]+      b2 =+        b & item . details <>~ [WashApply "A" (b ^. item . amount)]+  -- A buy and sell at a loss, followed by a buy+  lift $+    processActionsWithChanges+      [ Buy <$> b,+        Sell <$> sl,+        Buy <$> b2+      ]+      @?== Right+        ( [ SawAction (Buy <$> b),+            AddEvent (Opened True <$> b),+            Result (Buy <$> (b & item . details <>~ [Position Open])),+            SawAction (Sell <$> sl),+            Result+              ( Sell+                  <$> ( sl & item . details+                          <>~ [Position Close, Loss 1]+                      )+              ),+            RemoveEvent 1,+            Submit (sl & item . price .~ 1),+            SaveWash "A" (sl & item . price .~ 1),+            Result (Wash <$> (sl & item . price .~ 1)),+            SubmitEnd,+            SawAction (Buy <$> b2),+            AddEvent+              ( Opened True+                  <$> ( b2 & item . details+                          <>~ [Washed 1]+                      )+              ),+            Result+              ( Buy+                  <$> ( b2 & item . details+                          <>~ [ Position Open,+                                Washed 1+                              ]+                      )+              )+          ],+          [ Buy <$> (b & item . details <>~ [Position Open]),+            Sell+              <$> ( sl & item . details+                      <>~ [ Position Close,+                            Loss 1+                          ]+                  ),+            Wash <$> (sl & item . price .~ 1),+            Buy+              <$> ( b2 & item . details+                      <>~ [ Position Open,+                            Washed 1+                          ]+                  )+          ]+        )++buyBuySellLoss :: Property+buyBuySellLoss = property $ do+  b <- forAll $ genTimed genLot+  let s = b+      sl = s & item . price -~ 1+  -- A buy, a buy and then a sell at a loss+  lift $+    processActionsWithChanges+      [ Buy <$> b,+        Buy <$> b,+        Sell <$> sl+      ]+      @?== Right+        ( [ SawAction (Buy <$> b),+            AddEvent (Opened True <$> b),+            Result (Buy <$> (b & item . details <>~ [Position Open])),+            SawAction (Buy <$> b),+            AddEvent (Opened True <$> b),+            Result (Buy <$> (b & item . details <>~ [Position Open])),+            SawAction (Sell <$> sl),+            Result+              ( Sell+                  <$> ( sl & item . details+                          <>~ [Position Close, Loss 1]+                      )+              ),+            RemoveEvent 1,+            Submit (sl & item . price .~ 1),+            RemoveEvent 2,+            AddEvent+              ( Opened True+                  <$> ( b & item . details+                          <>~ [Washed 1]+                      )+              ),+            Result+              ( Wash+                  <$> ( b & item . price .~ 1+                          & item . details <>~ [Washed (b ^. item . price)]+                      )+              ),+            SubmitEnd+          ],+          [ Buy <$> (b & item . details <>~ [Position Open]),+            Buy <$> (b & item . details <>~ [Position Open]),+            Sell+              <$> (sl & item . details <>~ [Position Close, Loss 1]),+            Wash+              <$> ( b & item . price .~ 1+                      & item . details <>~ [Washed (b ^. item . price)]+                  )+          ]+        )++simpleSell :: Property+simpleSell = property $ do+  s <- forAll $ genTimed genLot+  -- A simple sell+  lift $+    processActionsWithChanges+      [Sell <$> s]+      @?== Right+        ( [ SawAction (Sell <$> s),+            AddEvent (Opened False <$> s),+            Result (Sell <$> (s & item . details <>~ [Position Open]))+          ],+          [Sell <$> (s & item . details <>~ [Position Open])]+        )++sellBuyProfit :: Property+sellBuyProfit = property $ do+  b <- forAll $ genTimed genLot+  let s = b+  -- A sell and buy at a profit+  lift $+    processActionsWithChanges+      [ Sell <$> s,+        Buy <$> b+      ]+      @?== Right+        ( [ SawAction (Sell <$> s),+            AddEvent (Opened False <$> s),+            Result (Sell <$> (s & item . details <>~ [Position Open])),+            SawAction (Buy <$> b),+            Result+              ( Buy+                  <$> (b & item . details <>~ [Position Close, Gain 0])+              ),+            RemoveEvent 1+          ],+          [ Sell <$> (s & item . details <>~ [Position Open]),+            Buy <$> (b & item . details <>~ [Position Close, Gain 0])+          ]+        )
+ trade-journal.cabal view
@@ -0,0 +1,109 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: bcab8d5bdeae3d554c45f80204fd191d5ad66fc5bcca8615b115e202dd2787cd++name:           trade-journal+version:        0.0.1+description:    Command-line reporting utility for processing trade journals.+author:         John Wiegley+maintainer:     johnw@newartisans.com+license:        BSD3+license-file:   LICENSE+build-type:     Simple++library+  exposed-modules:+      Journal.Amount+      Journal.Model+      Journal.Parse+      Journal.Split+      Journal.ThinkOrSwim+      Journal.Types+      Journal.Utils+  other-modules:+      Paths_trade_journal+  hs-source-dirs:+      src+  c-sources:+      src/Journal/mpfr_printf.c+  extra-libraries:+      mpfr+      gmp+  build-depends:+      aeson+    , base >=4.5 && <5.0+    , bytestring+    , cassava+    , containers+    , data-default+    , lens+    , megaparsec+    , mtl+    , pretty+    , pretty-show+    , profunctors+    , split+    , text+    , time+    , transformers+    , unordered-containers+    , vector+  default-language: Haskell2010++executable trade-journal+  main-is: Main.hs+  other-modules:+      Options+  build-depends:+      aeson+    , base >=4.5 && <5.0+    , bytestring+    , cassava+    , containers+    , lens+    , megaparsec+    , mtl+    , optparse-applicative+    , pretty-show+    , text+    , time+    , trade-journal+    , transformers+    , unordered-containers+  default-language: Haskell2010++test-suite trade-journal-tests+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Examples+      ModelTests+      Paths_trade_journal+  hs-source-dirs:+      test+  build-depends:+      HUnit+    , aeson+    , base >=4.5 && <5.0+    , bytestring+    , cassava+    , containers+    , hedgehog+    , here+    , lens+    , megaparsec+    , mtl+    , pretty-show+    , tasty+    , tasty-hedgehog+    , tasty-hunit+    , text+    , time+    , trade-journal+    , transformers+    , unordered-containers+  default-language: Haskell2010