UMM-0.1.5: UMMEval.hs

{- Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>

This file is part of umm, Uwe's Money Manager.

umm is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3 of the License, or (at your
option) any later version.

umm is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
License for more details.

You should have received a copy of the GNU General Public License
along with umm; if not, write to the Free Software Foundation, Inc.,
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

$Id: UMMEval.hs,v 1.33 2009/12/15 06:05:44 uwe Exp $ -}

module UMMEval (validateRecs, classifyRecs, validateTransPrices,
                generateImplicitPrices, getBalances, getPrices) where
import Prelude hiding (putStr,putStrLn,print)
import Data.List
import Data.Maybe
import System.IO.UTF8
import Control.Monad

import UMMData

-- Internal error: complain loudly!

intErr :: (Show i) => String -> i -> o
intErr loc w =
  error ("internal error at " ++ loc ++ "\ngot unexpected " ++ show w)

showErrs :: (Show i) => String -> [i] -> IO o
showErrs msg errs =
  putStrLn ("There were " ++ msg ++ " in the input:") >>
  mapM_ print errs >> error "quitting now"

-- Add the default ccs to a CCSAmt that has a blank ccs

addDCCA :: Name -> CCSAmt -> CCSAmt
addDCCA dc c@(CCSAmt n a) = if n == noName then CCSAmt dc a else c

-- Initial validation of records: filter out comments, highlight parse
-- errors, and check that dates are valid. This is kind of a trivial
-- use of runLedger, it could almost be accomplished by partition.

validateRecs :: [Record] -> IO [Record]
validateRecs records =
  do let (_,i,e) = runLedger (chk records)
     if null e
        then return i
        else showErrs "parse or date errors" e
  where chk [] = return ()
        chk (r@(ErrorRec _):rs) = recordErr r >> chk rs
        chk ((CommentRec _):rs) = chk rs
        chk (r:rs) =
            (if validDate (getRecDate r) then recordInfo else recordErr) r
            >> chk rs

-- Classify records by type and sort accounts and
-- transaction-type records by date or name as needed

-- TODO: should really check that there are no duplications among
-- account names and account group names together, rather than
-- separately (or just account groups, right now)

classifyRecs :: [Record] -> (Name, [Record], [Record], [Record],
                             [Record], [Record], [Record], [Record])
classifyRecs recs = cw recs [] [] [] [] [] [] []
  where cw [] c i e a g t p =
          let dc = if null c then Name "zorkmid" else getRecName (last c)
          in (dc, vsN c, vsN i, vsN e, reverse a, vsN g, asD dc t, asD dc p)
        cw (r:rs) c i e a g t p =
          case r of
            CommentRec _     -> cw rs c i e a g t p
            CCSRec _ _ _     -> cw rs (r:c) i e a g t p
            IncomeRec _ _    -> cw rs c (r:i) e a g t p
            ExpenseRec _ _   -> cw rs c i (r:e) a g t p
            AccountRec _ _ _ -> cw rs c i e (r:a) g t p
            GroupRec _ _     -> cw rs c i e a (r:g) t p
            PriceRec _ _ _ _ -> cw rs c i e a g t (r:p)
            _                -> cw rs c i e a g (r:t) p
        vsN = uChk . sortBy cmpRecName
        uChk [] = []
        uChk s@(_:[]) = s
        uChk v@(v1:v2:[]) = uc1 v1 v2 v
        uChk v@(v1:v2:_) = uc1 v1 v2 (v1 : uChk (tail v))
        uc1 v1 v2 r = if getRecName v1 == getRecName v2 then uErr v1 v2 else r
        uErr v1 v2 =
          error ("duplicate records\n  " ++ show v1 ++ "\n  " ++ show v2)
        asD dc = sortBy cmpRecDate . reverse . map (addDC dc)
        addDC dc (PriceRec d imp ccsa1 ccsa2) =
          PriceRec d imp ccsa1 (addDCCA dc ccsa2)
        addDC dc (XferRec d f from tos m c) =
          XferRec d f from (map (addDCCAt dc) tos) m c
        addDC dc (ExchRec t d f acc ccsa1 ccsa2 m) =
          ExchRec t d f acc (addDCCA dc ccsa1) (addDCCA dc ccsa2) m
        addDC _ r = r
        addDCCAt d (n,a) = (n, addDCCA d a)

-- Second validation of transactions: check that all from & to accounts
-- are valid, that splits aren't 1/0 or 0/1, etc

-- TODO: if we want to give a reason for each failure, run this
-- through runLedger as above? then we could generate multiple output
-- records for (some of) each input record

validateTransPrices :: [Record] -> [Record] -> [Record] ->
                       [Record] -> [Record] -> IO ()
validateTransPrices ccs incs exps accts tps =
  do let bads = filter chk tps
     unless (null bads) (showErrs "bad transactions" bads)
  where chk (SplitRec _ c (Amount amt1) (Amount amt2)) =
            amt1 == 0 || amt2 == 0 || notIn c ccs
        chk (PriceRec _ _ (CCSAmt c1 amt1) (CCSAmt c2 _)) =
            amt1 == Amount 0 || notIn c1 ccs || notIn c2 ccs
        chk (XferRec _ _  from tos _ _) =
            (notIn from incs && notIn from accts) || any chkTo tos
        chk (ExchRec _ _ _ a (CCSAmt c1 _) (CCSAmt c2 _) _) =
            notIn a accts || notIn c1 ccs || notIn c2 ccs
        chk (ToDoRec _ _ _) = False
        chk _ = True
        chkTo (to, CCSAmt n _) =
          (notIn to exps && notIn to accts) || notIn n ccs
        notIn _ [] = True
        notIn s (r:rs) = s /= getRecName r && notIn s rs

-- Generate implicit price/date information from buy and sell transactions;
-- presumably, these will have taken place at market price, which is what we
-- want. Only generate info for transactions involving the default currency,
-- other stuff is too hard to untangle at least for now.

generateImplicitPrices :: Name -> [Record] -> [Record] -> [Record]
generateImplicitPrices dc trs ccs = gip (geni ccs) trs
  where geni = map gii . filter iJ . filter nD
        nD r = getRecName r /= dc
        iJ (CCSRec _ _ ma) = isJust ma
        iJ r = intErr "generateImplicitPrices:1" r
        gii (CCSRec n _ (Just a)) =
          PriceRec startTime True (CCSAmt n (Amount 1)) (addDCCA dc a)
        gii r = intErr "generateImplicitPrices:2" r
        gip acc [] = filter pr acc
        gip acc (t@(ExchRec _ _ _ _ _ _ _):ts) = gip (genp t : acc) ts
        gip acc (_:ts) = gip acc ts
        genp (ExchRec _ date _ _ (CCSAmt n1 a1) (CCSAmt n2 a2) _)
          | n1 == dc   = PriceRec date True (nC n2 a2 a2) (nC n1 a1 a2)
          | n2 == dc   = PriceRec date True (nC n1 a1 a1) (nC n2 a2 a1)
          | otherwise  = CommentRec "general exchange, no price generated"
        genp r = intErr "generateImplicitPrices:3" r
        pr (PriceRec _ _ _ _) = True
        pr _ = False
        nC n (Amount a1) (Amount a2) =
          CCSAmt n (Amount (if a2 == 0 then a1 else roundP 4 (a1/a2)))

getCN :: CCSAmt -> Name
getCN (CCSAmt n _) = n

getCA :: CCSAmt -> Rational
getCA (CCSAmt _ (Amount a)) = a

addTo :: [CCSAmt] -> CCSAmt -> [CCSAmt]
addTo [] n = [n]
addTo (q:qs) d =
  let qn = getCN q
      qq = getCA q
      dn = getCN d
      dq = getCA d
      nq = qq + dq
  in if qn == dn
        then if nq == 0 then qs else CCSAmt qn (Amount nq) : qs
        else q : addTo qs d

subFrom :: [CCSAmt] -> CCSAmt -> [CCSAmt]
subFrom acc d = addTo acc (CCSAmt (getCN d) (Amount (-(getCA d))))

scaleBy :: [CCSAmt] -> CCSAmt -> [CCSAmt]
scaleBy qs d = map (s1 (getCN d) (getCA d)) qs
  where s1 dn dq q =
          let qn = getCN q
              qq = getCA q
          in if qn == dn then CCSAmt qn (Amount (qq * dq)) else q

maybeRecord :: Maybe Name -> Record -> AccountData -> (Name -> Bool) ->
               Ledger e (Record, [CCSAmt]) ()
maybeRecord reg record newaccs tst =
  let isJ = isJust reg
      rn = fromJust reg
      acc = filter (\a -> fst a == rn) newaccs
      nb = if null acc
              then [CCSAmt noName (Amount 0)]
              else snd (head acc)
  in if isJ && (tst rn || rn == noName)
        then recordInfo (record, nb)
        else recordNil

maybeDo :: Maybe Name -> Bool -> Record -> Bool ->
           AccountData -> AccountData -> (Name -> Bool) ->
           Ledger e (Record, [CCSAmt]) AccountData
maybeDo reg dorec record isrec accs newaccs tst =
  if dorec
     then if isrec
             then return newaccs
             else maybeRecord reg record newaccs tst >> return accs
     else maybeRecord reg record newaccs tst >> return newaccs

exchTrans :: Maybe Name -> Bool -> Record -> AccountData ->
             Ledger e (Record, [CCSAmt]) AccountData
exchTrans reg dorec record@(ExchRec _ _ isrec acc amtn amto _) accs =
  maybeDo reg dorec record isrec accs
          (doExch accs acc amtn amto) (== acc)
  where doExch [] _ _ _ = []
        doExch ((an,ab):as) n en eo =
          if an == n
             then (an, subFrom (addTo ab en) eo) : as
             else (an,ab) : doExch as n en eo
exchTrans _ _ r _ = intErr "exchTrans" r

xferTrans :: Maybe Name -> Bool -> Record -> AccountData ->
             Ledger e (Record, [CCSAmt]) AccountData
xferTrans reg dorec record@(XferRec _ isrec from tos _ _) accs = foldM xfer1 accs tos
  where xfer1 as (to,amt) = maybeDo reg dorec record isrec as
                                    (doXfer as from to amt)
                                    (\rn -> rn == from || rn == to)
        doXfer [] _ _ _ = []
        doXfer (a@(an,ab):as) nf nt e
          | an == nf    = (an, subFrom ab e) : doXfer as nf nt e
          | an == nt    = (an, addTo ab e) : doXfer as nf nt e
          | otherwise   = a : doXfer as nf nt e
xferTrans _ _ r _ = intErr "xferTrans" r

-- TODO: look into account and see if split is applicable? yeah... cleaner
-- Also: does maybeDo apply here, too? I think probably it should...
-- but is this a reconcilable transaction? It reaches across accounts,
-- so maybe not

splitTrans :: Maybe Name -> Record -> AccountData ->
              Ledger e (Record, [CCSAmt]) AccountData
splitTrans reg record@(SplitRec _ ccs (Amount an) (Amount ao)) acc =
  let newaccs = map doST acc
  in maybeRecord reg record newaccs (const True) >> return newaccs
  where doST (a1,a2) = (a1, scaleBy a2 (CCSAmt ccs (Amount (an/ao))))
splitTrans _ r _ = intErr "splitTrans" r

mkInit :: Monad m => [Record] -> m AccountData
mkInit as = return (map (\a -> (getRecName a, [])) as)

appTr :: Date -> Maybe Name -> Bool -> [Record] -> AccountData ->
         Ledger Record (Record, [CCSAmt]) AccountData
appTr _ _ _ [] as = return as
appTr d r f (t:ts) as =
  if getRecDate t > d
     then return as
     else case t of
            XferRec _ _ _ _ _ _ -> xferTrans r f t as >>= appTr d r f ts
            ExchRec _ _ _ _ _ _ _ -> exchTrans r f t as >>= appTr d r f ts
            SplitRec _ _ _ _  -> splitTrans r t as >>= appTr d r f ts
            ToDoRec _ isrec _ ->
              (if isrec then recordNil else recordInfo (t,[]))
                >> appTr d r f ts as
            _ -> recordErr t >> appTr d r f ts as

showT :: (Record, [CCSAmt]) -> IO ()
showT (t,_) = print t

showTB :: (Record, [CCSAmt]) -> IO ()
showTB e@(_,b) = showT e >> mapM_ sB b
  where sB ccsa = putStrLn ('\t' : show ccsa)

getBalances :: Date -> Date -> Maybe Name -> Bool ->
               [Record] -> [Record] -> IO AccountData
getBalances date1 date2 reg dorec accts trans =
  do let (r,i1,e) = runLedger (mkInit accts >>= appTr date2 reg dorec trans)
         i = dropWhile (\t -> getRecDate (fst t) < date1) i1
         ss = if dorec then showT else showTB
     unless (null e) (showErrs "processing errors" e)
     unless (null i) (putStrLn "Notes:" >> mapM_ ss i >> putStrLn "")
     return r

-- For now, we don't generate "swap prices" internally, so unless the user
-- enters some, we won't see any; see also generateImplicitPrices above.

getPrices :: Name -> Name -> Date -> [Record] -> IO ()
getPrices nm dc date prices =
  do let p1 = dropWhile (\t -> date < getRecDate t) prices
         (_,i,e) = runLedger (get p1)
     unless (null e) (doShow "Swap \"Prices\"" e >> putStrLn "")
     unless (null i) (doShow "Ordinary Prices" i)
     when (null i && null e)
          (putStrLn ("No prices known for " ++ show nm))
  where get [] = return ()
        get (p@(PriceRec _ _ (CCSAmt nr1 _) (CCSAmt nr2 _)):ps) =
          if (nr1 == nm && nr2 == dc) || (nr1 == dc && nr2 == nm)
             then recordInfo p >> get ps
             else if nr1 == nm || nr2 == nm
                     then recordErr p >> get ps
                     else get ps
        get _ = recordNil
        doShow t p = putStrLn t >> mapM_ print (reverse p)