-- | Parsec parsers for the ledger file format. The format is
-- documented in EBNF in the file @doc\/ledger-grammar.org@.
module Penny.Copper.Parsec where

import qualified Penny.Copper.Terminals as T
import qualified Penny.Copper.Types as Y
import Text.Parsec.Text (Parser)
import Text.Parsec (many, many1, satisfy)
import qualified Text.Parsec as P
import qualified Text.Parsec.Pos as Pos
import Control.Arrow (first, second)
import Control.Applicative ((<$>), (<$), (<*>), (*>), (<*),
                            (<|>), optional)
import Control.Monad (replicateM)
import qualified Control.Monad.Exception.Synchronous as Ex
import qualified Penny.Lincoln as L
import qualified Penny.Lincoln.Transaction.Unverified as U
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack)
import qualified Data.Time as Time

lvl1SubAcct :: Parser L.SubAccount
lvl1SubAcct =
  (L.SubAccount . pack) <$> many1 (satisfy T.lvl1AcctChar)

lvl1FirstSubAcct :: Parser L.SubAccount
lvl1FirstSubAcct = lvl1SubAcct

lvl1OtherSubAcct :: Parser L.SubAccount
lvl1OtherSubAcct = satisfy T.colon *> lvl1SubAcct

lvl1Acct :: Parser L.Account
lvl1Acct = f <$> lvl1FirstSubAcct <*> many lvl1OtherSubAcct
  where
    f a as = L.Account (a:as)

quotedLvl1Acct :: Parser L.Account
quotedLvl1Acct =
  satisfy T.openCurly *> lvl1Acct <* satisfy T.closeCurly

lvl2FirstSubAcct :: Parser L.SubAccount
lvl2FirstSubAcct =
  (\c cs -> L.SubAccount (pack (c:cs)))
  <$> satisfy T.letter
  <*> many (satisfy T.lvl2AcctOtherChar)

lvl2OtherSubAcct :: Parser L.SubAccount
lvl2OtherSubAcct =
  (L.SubAccount . pack)
  <$ satisfy T.colon
  <*> many1 (satisfy T.lvl2AcctOtherChar)

lvl2Acct :: Parser L.Account
lvl2Acct =
  (\a as -> L.Account (a:as))
  <$> lvl2FirstSubAcct
  <*> many lvl2OtherSubAcct

ledgerAcct :: Parser L.Account
ledgerAcct = quotedLvl1Acct <|> lvl2Acct

lvl1Cmdty :: Parser L.Commodity
lvl1Cmdty = (L.Commodity . pack) <$> many1 (satisfy T.lvl1CmdtyChar)

quotedLvl1Cmdty :: Parser L.Commodity
quotedLvl1Cmdty =
  satisfy T.doubleQuote *> lvl1Cmdty <* satisfy (T.doubleQuote)

lvl2Cmdty :: Parser L.Commodity
lvl2Cmdty =
  (\c cs -> L.Commodity (pack (c:cs)))
  <$> satisfy T.lvl2CmdtyFirstChar
  <*> many (satisfy T.lvl2CmdtyOtherChar)

lvl3Cmdty :: Parser L.Commodity
lvl3Cmdty = (L.Commodity . pack) <$> many1 (satisfy T.lvl3CmdtyChar)

digitGroup :: Parser [Char]
digitGroup = satisfy T.thinSpace *> many1 (satisfy T.digit)

digitSequence :: Parser [Char]
digitSequence =
  (++) <$> many1 (satisfy T.digit)
  <*> (concat <$> (many digitGroup))

digitPostSequence :: Parser (Maybe [Char])
digitPostSequence = satisfy T.period *> optional digitSequence

quantity :: Parser L.Qty
quantity = p >>= failOnErr
  where
    p = (L.RadFrac <$> (satisfy T.period *> digitSequence))
        <|> (f <$> digitSequence <*> optional digitPostSequence)
    f digSeq maybePostSeq = case maybePostSeq of
      Nothing -> L.Whole digSeq
      Just ps ->
        maybe (L.WholeRad digSeq) (L.WholeRadFrac digSeq) ps
    failOnErr = maybe (fail msg) return . L.toQty
    msg = "could not read quantity; zero quantities not allowed"

spaceBetween :: Parser L.SpaceBetween
spaceBetween = f <$> optional (many1 (satisfy T.white))
  where
    f = maybe L.NoSpaceBetween (const L.SpaceBetween)

leftCmdtyLvl1Amt :: Parser L.Amount
leftCmdtyLvl1Amt =
  f <$> quotedLvl1Cmdty <*> spaceBetween <*> quantity
  where
    f c s q = L.Amount q c (Just L.CommodityOnLeft) (Just s)

leftCmdtyLvl3Amt :: Parser L.Amount
leftCmdtyLvl3Amt = f <$> lvl3Cmdty <*> spaceBetween <*> quantity
  where
    f c s q = L.Amount q c (Just L.CommodityOnLeft) (Just s)

leftSideCmdtyAmt :: Parser L.Amount
leftSideCmdtyAmt = leftCmdtyLvl1Amt <|> leftCmdtyLvl3Amt

rightSideCmdty :: Parser L.Commodity
rightSideCmdty = quotedLvl1Cmdty <|> lvl2Cmdty

rightSideCmdtyAmt :: Parser L.Amount
rightSideCmdtyAmt =
  f <$> quantity <*> spaceBetween <*> rightSideCmdty
  where
    f q s c = L.Amount q c (Just L.CommodityOnRight) (Just s)


amount :: Parser L.Amount
amount = leftSideCmdtyAmt <|> rightSideCmdtyAmt

comment :: Parser Y.Comment
comment =
  (Y.Comment . pack)
  <$ satisfy T.hash
  <*> many (satisfy T.nonNewline)
  <* satisfy T.newline
  <* many (satisfy T.white)

year :: Parser Integer
year = read <$> replicateM 4 P.digit

month :: Parser Int
month = read <$> replicateM 2 P.digit

day :: Parser Int
day = read <$> replicateM 2 P.digit

date :: Parser Time.Day
date = p >>= failOnErr
  where
    p = Time.fromGregorianValid
        <$> year  <* satisfy T.dateSep
        <*> month <* satisfy T.dateSep
        <*> day
    failOnErr = maybe (fail "could not parse date") return

hours :: Parser L.Hours
hours = p >>= (maybe (fail "could not parse hours") return)
  where
    p = f <$> satisfy T.digit <*> satisfy T.digit
    f d1 d2 = L.intToHours . read $ [d1,d2]


minutes :: Parser L.Minutes
minutes = p >>= maybe (fail "could not parse minutes") return
  where
    p = f <$ satisfy T.colon <*> satisfy T.digit <*> satisfy T.digit
    f d1 d2 = L.intToMinutes . read $ [d1, d2]

seconds :: Parser L.Seconds
seconds = p >>= maybe (fail "could not parse seconds") return
  where
    p = f <$ satisfy T.colon <*> satisfy T.digit <*> satisfy T.digit
    f d1 d2 = L.intToSeconds . read $ [d1, d2]

time :: Parser (L.Hours, L.Minutes, Maybe L.Seconds)
time = (,,) <$> hours <*> minutes <*> optional seconds

tzSign :: Parser (Int -> Int)
tzSign = (id <$ satisfy T.plus) <|> (negate <$ satisfy T.minus)

tzNumber :: Parser Int
tzNumber = read <$> replicateM 4 (satisfy T.digit)

timeZone :: Parser L.TimeZoneOffset
timeZone = p >>= maybe (fail "could not parse time zone") return
  where
    p = f <$> tzSign <*> tzNumber
    f s = L.minsToOffset . s

timeWithZone
  :: Parser (L.Hours, L.Minutes,
             Maybe L.Seconds, Maybe L.TimeZoneOffset)
timeWithZone =
  f <$> time <* many (satisfy T.white) <*> optional timeZone
  where
    f (h, m, s) tz = (h, m, s, tz)

dateTime :: Parser L.DateTime
dateTime =
  f <$> date <* many (satisfy T.white) <*> optional timeWithZone
  where
    f d mayTwithZ = L.DateTime d h m s tz
      where
        ((h, m, s), tz) = case mayTwithZ of
          Nothing -> (L.midnight, L.noOffset)
          Just (hr, mn, mayS, mayTz) ->
            let sec = fromMaybe L.zeroSeconds mayS
                z = fromMaybe L.noOffset mayTz
            in ((hr, mn, sec), z)

debit :: Parser L.DrCr
debit = L.Debit <$ satisfy T.lessThan

credit :: Parser L.DrCr
credit = L.Credit <$ satisfy T.greaterThan

drCr :: Parser L.DrCr
drCr = debit <|> credit

entry :: Parser L.Entry
entry = f <$> drCr <* (many (satisfy T.white)) <*> amount
  where
    f dc am = L.Entry dc am

flag :: Parser L.Flag
flag = (L.Flag . pack) <$ satisfy T.openSquare
  <*> many (satisfy T.flagChar) <* satisfy (T.closeSquare)

postingMemoLine :: Parser Text
postingMemoLine =
  pack
  <$ satisfy T.apostrophe
  <*> many (satisfy T.nonNewline)
  <* satisfy T.newline <* many (satisfy T.white)

postingMemo :: Parser L.Memo
postingMemo = L.Memo <$> many1 postingMemoLine

transactionMemoLine :: Parser Text
transactionMemoLine =
  pack
  <$ satisfy T.semicolon <*> many (satisfy T.nonNewline)
  <* satisfy T.newline <* skipWhite

transactionMemo :: Parser (L.TopMemoLine, L.Memo)
transactionMemo = f <$> lineNum <*> many1 transactionMemoLine
  where
    f tml ls = (L.TopMemoLine tml
               , L.Memo ls)


number :: Parser L.Number
number =
  L.Number . pack <$ satisfy T.openParen
  <*> many (satisfy T.numberChar) <* satisfy T.closeParen

lvl1Payee :: Parser L.Payee
lvl1Payee = L.Payee . pack <$> many (satisfy T.quotedPayeeChar)

quotedLvl1Payee :: Parser L.Payee
quotedLvl1Payee = satisfy T.tilde *> lvl1Payee <* satisfy T.tilde

lvl2Payee :: Parser L.Payee
lvl2Payee = (\c cs -> L.Payee (pack (c:cs))) <$> satisfy T.letter
            <*> many (satisfy T.nonNewline)

fromCmdty :: Parser L.From
fromCmdty = L.From <$> (quotedLvl1Cmdty <|> lvl2Cmdty)

lineNum :: Parser Int
lineNum = Pos.sourceLine <$> P.getPosition

price :: Parser L.PricePoint
price = p >>= maybe (fail msg) return
  where
    f li dt fr (L.Amount qt to sd sb) =
      let cpu = L.CountPerUnit qt
      in case L.newPrice fr (L.To to) cpu of
        Nothing -> Nothing
        Just pr -> Just $ L.PricePoint dt pr
                          sd sb (Just $ L.PriceLine li)
    p = f <$> lineNum <* satisfy T.atSign <* skipWhite
        <*> dateTime <* skipWhite
        <*> fromCmdty <* skipWhite
        <*> amount <* satisfy T.newline <* skipWhite
    msg = "could not parse price, make sure the from and to commodities "
          ++ "are different"

tag :: Parser L.Tag
tag = L.Tag . pack <$ satisfy T.asterisk <*> many (satisfy T.tagChar)
      <* many (satisfy T.white)

tags :: Parser L.Tags
tags = (\t ts -> L.Tags (t:ts)) <$> tag <*> many tag

topLinePayee :: Parser L.Payee
topLinePayee = quotedLvl1Payee <|> lvl2Payee

topLineFlagNum :: Parser (Maybe L.Flag, Maybe L.Number)
topLineFlagNum = p1 <|> p2
  where
    p1 = ( (,) <$> optional flag
               <* many (satisfy T.white) <*> optional number)
    p2 = ( flip (,)
           <$> optional number
           <* many (satisfy T.white) <*> optional flag)

skipWhite :: Parser ()
skipWhite = () <$ many (satisfy T.white)

topLine :: Parser U.TopLine
topLine =
  f <$> optional transactionMemo
    <*> lineNum
    <*> dateTime
    <*  skipWhite
    <*> topLineFlagNum
    <*  skipWhite
    <*> optional topLinePayee
    <*  satisfy T.newline
    <*  skipWhite
  where
    f mayMe lin dt (mayFl, mayNum) mayPy =
      U.TopLine dt mayFl mayNum mayPy me tll tml Nothing
      Nothing Nothing
      where
        (tml, me) = case mayMe of
          Nothing -> (Nothing, Nothing)
          Just (l, m) -> (Just l, Just m)
        tll = Just (L.TopLineLine lin)

pairedMaybes
  :: Parser (a, Maybe b)
  -> Parser (Maybe a, b)
  -> Parser (Maybe a, Maybe b)
pairedMaybes p1 p2 =
  (fmap (first Just) p1) <|> (fmap (second Just) p2)

parsePair
  :: Parser a
  -> Parser b
  -> Parser (Maybe a, Maybe b)
parsePair a b = pairedMaybes aFirst bFirst
  where
    aFirst = (,) <$> a <* skipWhite <*> optional b
    bFirst = flip (,) <$> b <* skipWhite <*> optional a

parseTriple
  :: Parser a
  -> Parser b
  -> Parser c
  -> Parser (a, Maybe b, Maybe c)
parseTriple a b c =
  f
  <$> a
  <* skipWhite
  <*> optional (parsePair b c)
  where
    f ra mayRbc = case mayRbc of
      Nothing -> (ra, Nothing, Nothing)
      Just (rb, rc) -> (ra, rb, rc)


flagFirst :: Parser (L.Flag, Maybe L.Number, Maybe L.Payee)
flagFirst = parseTriple flag number quotedLvl1Payee

numberFirst :: Parser (L.Number, Maybe L.Flag, Maybe L.Payee)
numberFirst = parseTriple number flag quotedLvl1Payee

payeeFirst :: Parser (L.Payee, Maybe L.Flag, Maybe L.Number)
payeeFirst = parseTriple quotedLvl1Payee flag number

flagNumPayee :: Parser (Maybe L.Flag, Maybe L.Number, Maybe L.Payee)
flagNumPayee =
  ((\(f, n, p) -> (Just f, n, p)) <$> flagFirst)
  <|> ((\(n, f, p) -> (f, Just n, p)) <$> numberFirst)
  <|> ((\(p, f, n) -> (f, n, Just p)) <$> payeeFirst)


postingAcct :: Parser L.Account
postingAcct = quotedLvl1Acct <|> lvl2Acct

posting :: Parser U.Posting
posting = f <$> lineNum                <* skipWhite
            <*> optional flagNumPayee  <* skipWhite
            <*> postingAcct            <* skipWhite
            <*> optional tags          <* skipWhite
            <*> optional entry         <* skipWhite
            <*  satisfy T.newline      <* skipWhite
            <*> optional postingMemo   <* skipWhite
  where
    f li mayFnp ac ta mayEn me =
      U.Posting pa nu fl ac tgs mayEn me pl Nothing Nothing
      where
        tgs = fromMaybe (L.Tags []) ta
        pl = Just . L.PostingLine $ li
        (fl, nu, pa) = fromMaybe (Nothing, Nothing, Nothing) mayFnp

transaction :: Parser L.Transaction
transaction = p >>= Ex.switch (fail . show) return
  where
    p = L.transaction <$>
        (L.Family <$> topLine <*> posting
        <*> posting <*> many posting)


blankLine :: Parser Y.Item
blankLine = Y.BlankLine <$ satisfy T.newline <* skipWhite

item :: Parser Y.Item
item = fmap Y.IComment comment <|> fmap Y.PricePoint price
       <|> fmap Y.Transaction transaction <|> blankLine

ledger :: Parser Y.Ledger
ledger = Y.Ledger <$ skipWhite <*> many item <* P.eof