containers                == 0.5.*,
    postgresql-simple         >= 0.3.10

    containers                == 0.5.*

    bifunctors,              

  , LogEvent(..)

  , WorkEvent(..)
  , WorkIndex

import Database.PostgreSQL.Simple.FromRow
import Database.PostgreSQL.Simple.FromField

-- import Database.PostgreSQL.Simple.FromRow
-- import Database.PostgreSQL.Simple.FromField

data LogEvent = StartWork | StopWork deriving (Show, Eq)

data WorkEvent = StartWork { logTime :: UTCTime }
              | StopWork  { logTime :: UTCTime } deriving (Show, Eq)

instance FromField LogEvent where
  fromField f m = let fromText "start_work" = return StartWork
                      fromText "stop_work"  = return StopWork
                      fromText a = conversionError $ LogEventParseError $ "unrecognized log event type " ++ a
                  in fromField f m >>= fromText

-- instance FromField WorkEvent where
--   fromField f m = let fromText "start_work" = return StartWork
--                       fromText "stop_work"  = return StopWork
--                       fromText a = conversionError $ LogEventParseError $ "unrecognized log event type " ++ a
--                   in fromField f m >>= fromText

                         , logTime :: UTCTime
                         , event :: LogEvent 

                         , event :: WorkEvent 

instance FromRow LogEntry where
  fromRow = LogEntry <$> field <*> field <*> field 

-- instance FromRow LogEntry where
--   fromRow = LogEntry <$> field <*> field <*> field 

type WorkIndex = Map BtcAddr ([LogEntry], [LogInterval])

type WorkIndex = Map BtcAddr ([WorkEvent], [Interval])

payouts dep ptime widx = let addIntervalDiff :: (Functor f, Foldable f) => NDT -> f LogInterval -> (NDT, NDT)
                             addIntervalDiff total ivals = (\dt -> (dt + total, dt)) $ sumLogIntervals dep ptime ivals 
                             (totalTime, keyTimes) = M.mapAccum addIntervalDiff (fromInteger 0) $ M.map snd widx
                         in M.map (\kt -> toRational $ kt / totalTime) keyTimes

payouts dep ptime widx = 
  let addIntervalDiff :: (Functor f, Foldable f) => NDT -> f Interval -> (NDT, NDT)
      addIntervalDiff total ivals = (\dt -> (dt + total, dt)) $ workCredit dep ptime ivals 
      (totalTime, keyTimes) = M.mapAccum addIntervalDiff (fromInteger 0) $ M.map snd widx
  in M.map (\kt -> toRational $ kt / totalTime) keyTimes

  Given a depreciation function, the "current" time, and a foldable functor of log intervals,
  produce the total, depreciated length of work to be credited to an address.

sumLogIntervals :: (Functor f, Foldable f) => Depreciation -> UTCTime -> f LogInterval -> NDT
sumLogIntervals dep ptime ivals = F.foldl' (+) (fromInteger 0) $ fmap (depreciateInterval dep ptime) ivals

workCredit :: (Functor f, Foldable f) => Depreciation -> UTCTime -> f Interval -> NDT
workCredit dep ptime ivals = F.foldl' (+) (fromInteger 0) $ fmap (depreciateInterval dep ptime) ivals

depreciateInterval :: Depreciation -> UTCTime -> LogInterval -> NDT
depreciateInterval dep ptime ival = let depreciation :: Rational
                                        depreciation = depf dep $ diffUTCTime ptime (end . workInterval $ ival)
                                    in  fromRational $ depreciation * (toRational . ilen . workInterval $ ival)

{-|
  Compute the depreciated difftime for a single Interval value.
-}
depreciateInterval :: Depreciation -> UTCTime -> Interval -> NDT
depreciateInterval dep ptime ival = 
  let depreciation :: Rational
      depreciation = depf dep $ diffUTCTime ptime (end $ ival)
  in  fromRational $ depreciation * (toRational . ilen $ ival)

intervals = F.foldl' appendLogEntry M.empty 

intervals logEntries = M.map (bimap (fmap event) (fmap workInterval)) $ F.foldl' appendLogEntry M.empty logEntries

appendLogEntry :: WorkIndex -> LogEntry -> WorkIndex
appendLogEntry workIndex entry = let acc = reduceToIntervals $ pushEntry entry workIndex 
                                 in insert (btcAddr entry) acc workIndex

type RawIndex = Map BtcAddr ([LogEntry], [LogInterval])

pushEntry :: LogEntry -> WorkIndex -> ([LogEntry], [LogInterval])

appendLogEntry :: RawIndex -> LogEntry -> RawIndex
appendLogEntry workIndex entry = 
  let acc = reduceToIntervals $ pushEntry entry workIndex 
  in insert (btcAddr entry) acc workIndex
pushEntry :: LogEntry -> RawIndex -> ([LogEntry], [LogInterval])

reduceToIntervals ((LogEntry addr end StopWork) : (LogEntry _ start StartWork) : xs, intervals) = (xs, (LogInterval addr (interval start end)) : intervals)

reduceToIntervals ((LogEntry addr (StopWork end)) : (LogEntry _ (StartWork start)) : xs, intervals) = 
  (xs, (LogInterval addr (interval start end)) : intervals)

import Database.PostgreSQL.Simple.FromField

--import Database.PostgreSQL.Simple.FromField

instance FromField BtcAddr where
  fromField f m = fmap BtcAddr $ fromField f m 

--instance FromField BtcAddr where
--  fromField f m = fmap BtcAddr $ fromField f m 

{-# LANGUAGE ScopedTypeVariables #-}

import Data.Bifunctor as B

  testLogEntries :: [LogEntry]

    [ LogEntry addr start StartWork, LogEntry addr end StopWork ]

    [ LogEntry addr (StartWork start), LogEntry addr (StopWork end) ]

  testIntervals :: [LogInterval]

  expected0 :: Map BtcAddr ([LogEntry], [LogInterval])
  expected0 = M.map (const [] &&& id) . fromListWith (++) . fmap (intervalBtcAddr &&& return) $ testIntervals

  expected = M.map (\i -> ([], i)) . fromListWith (++) . fmap (intervalBtcAddr &&& return) $ testIntervals

  expected :: WorkIndex
  expected = M.map (bimap (fmap event) (fmap workInterval)) expected0