{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE NoOverloadedLists #-}
{-# LANGUAGE UndecidableInstances #-}
--{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE StandaloneDeriving #-}
module Symantic.Compta.Input.Journal where

import Control.Applicative (Applicative(..), liftA2)
import Control.Monad (Monad(..))
--import Data.Either (Either(..))
import Data.Bool
import Data.Function (($), (.))
import Data.Functor (Functor(..), (<$>))
--import Data.Map.Strict (Map)
--import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import GHC.Stack (HasCallStack)
import Prelude (undefined)
import Text.Show (Show(..))
--import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.Writer as MT
--import qualified Data.Map.Strict as Map

import Symantic.Compta.Lang as List
import Symantic.Compta.Calc.Balance
--import Symantic.Compta.Calc.Chart
import Symantic.Compta.Calc.Unit

import Debug.Trace

-- * Type 'JournalDo'
-- | This 'Monad' enables the 'do' syntax for entering 'move's and 'post's,
-- which is less verbose than the list syntax.
newtype JournalDo repr a = JournalDo { unJournalDo ::
  MT.Writer (JournalGenerator repr) a
  } deriving newtype (Functor, Applicative, Monad)
type instance Ty (JournalDo repr) TyUnit = Ty repr TyUnit
instance Unitable repr => Unitable (JournalDo repr) where
  unit u = JournalDo . MT.mapWriter (go <$>) . unJournalDo
    where
    go JournalGenerator{..} = JournalGenerator
      { moves = unit u moves
      , posts = unit u posts
      }

runJournalDo :: HasCallStack => JournalDo repr a -> repr [TyMove]
runJournalDo p =
  let (_a, out) = MT.runWriter (unJournalDo p) in
  moves out

-- ** Type 'JournalGenerator'
data JournalGenerator repr = JournalGenerator
  { moves :: repr [TyMove]
  , posts :: repr [TyPost]
  }
instance Listable repr => Semigroup (JournalGenerator repr) where
  x <> y = JournalGenerator
    { moves = moves x `concat` moves y
    , posts = posts x `concat` posts y
    }
instance Listable repr => Monoid (JournalGenerator repr) where
  mempty = JournalGenerator
    { moves = nil
    , posts = nil
    }
instance
  ( Negable (repr [TyMove])
  , Negable (repr [TyPost])
  ) => Negable (JournalGenerator repr) where
  negate JournalGenerator{..} = JournalGenerator
    { moves = negate moves
    , posts = negate posts
    }

data JournalRepr repr a where
  JournalReprAny ::
    Balanceable a ~ 'False =>
    repr a -> JournalRepr repr a
  JournalRepr ::
    --Balanceable a ~ 'True =>
    JournalDo repr a -> JournalRepr repr a

instance Functor (JournalRepr repr) where
  fmap f = \case
    JournalRepr fx -> JournalRepr (fmap f fx)
instance Listable repr => Applicative (JournalRepr repr) where
  pure = JournalRepr . pure
  JournalRepr fa <*> JournalRepr fb = JournalRepr (fa <*> fb)
instance Listable repr => Monad (JournalRepr repr) where
  return = JournalRepr . return
  JournalRepr ma >>= f = JournalRepr $ ma >>= \a ->
    case f a of
      JournalRepr mb -> mb

type instance Ty (JournalRepr repr) TyUnit = Ty repr TyUnit

runJournalRepr :: JournalRepr repr TyMove -> repr [TyMove]
runJournalRepr = \case
  JournalRepr j -> runJournalDo j
instance
  Unitable repr =>
  Unitable (JournalRepr repr) where
  unit u = \case
    JournalReprAny x -> JournalReprAny (unit u x)
    JournalRepr x -> JournalRepr (unit u x)

{-
instance
  ( Listable repr
  , Monad m
  ) => IsList (JournalRepr acct amt repr [a]) where
  type Item (JournalRepr acct amt repr [a]) = JournalRepr acct amt repr a
  fromList = Foldable.foldr cons nil
  toList x = error "toList"
  fromListN _len = fromList
-}
instance Listable repr => Listable (JournalRepr repr) where
  nil = JournalRepr $ return []
  cons (JournalRepr x) (JournalRepr xs) = JournalRepr $ liftA2 (:) x xs
  -- NOTE: those two should never be needed, but Balanceable can't rule them out
  cons (JournalReprAny x) (JournalRepr xs) = JournalRepr $
    liftA2 (:) (JournalDo (return undefined)) xs
  concat (JournalRepr xs) (JournalRepr ys) = JournalRepr $ liftA2 (<>) xs ys
instance Zeroable (repr TyAmount) => Zeroable (JournalRepr repr TyAmount) where
  zero = JournalReprAny zero
instance Addable (repr TyAmount) => Addable (JournalRepr repr TyAmount) where
  JournalReprAny x + JournalReprAny y = JournalReprAny (x + y)
instance
  ( Negable (repr [TyMove])
  , Negable (repr [TyPost])
  , Negable (repr a)
  ) => Negable (JournalRepr repr a) where
  negate (JournalReprAny x) = JournalReprAny (negate x)
  negate (JournalRepr x) = JournalRepr $ JournalDo $
    MT.mapWriter (negate <$>) $ unJournalDo x
instance
  ( Listable repr
  , FromInteger (repr TyAmount)
  ) => FromInteger (JournalRepr repr TyAmount) where
  fromInteger = JournalReprAny . fromInteger
instance
  ( Listable repr
  , FromInteger (repr TyAccount)
  ) => FromInteger (JournalRepr repr TyAccount) where
  fromInteger = JournalReprAny . fromInteger
instance
  ( Listable repr
  , Accountable repr
  , Amountable repr
  , Postable repr
  , Zeroable (repr TyAmount)
  , FromInteger (repr TyAccount)
  ) => FromInteger (JournalRepr repr TyPost) where
  fromInteger i = post (fromInteger i) zero
instance
  ( Listable repr
  , Accountable repr
  , Amountable repr
  , Postable repr
  , Zeroable (repr TyAmount)
  , FromInteger (repr TyAccount)
  ) => FromInteger (JournalRepr repr [TyPost]) where
  fromInteger i = post (fromInteger i) zero `cons` nil
{-
instance
  ( Postable repr
  , FromInteger (JournalRepr repr acct)
  , Listable repr
  , Monad m
  ) => FromInteger (JournalRepr repr [TyPost]) where
  fromInteger i = cons (fromInteger i) nil
instance
  ( Postable repr
  , IsString (JournalRepr repr acct)
  , Listable repr
  , Monad m
  ) => IsString (JournalRepr repr TyPost) where
  fromString s = do
    acct :: acct <- fromString s
    post acct (Map.empty :: Map unit qty)
instance
  ( Postable repr
  , IsString (JournalRepr repr acct)
  , Listable repr
  , Monad m
  ) => IsString (JournalRepr repr [TyPost]) where
  fromString s = do
    acct :: acct <- fromString s
    cons (post acct (Map.empty :: Map unit qty)) nil
instance
  ( FromRational qty
  , Listable repr
  , Monad m
  ) => FromRational (JournalRepr repr qty) where
  fromRational = JournalRepr . return . fromRational
type instance QuantityOf (Map unit qty) = qty
instance
  ( IsString unit
  , Monad m
  ) => EURable (Map unit qty) (JournalRepr repr) where
  eur = (Map.singleton "€" <$>)
-}
instance EURable repr => EURable (JournalRepr repr) where
  eur (JournalReprAny x) = JournalReprAny (eur x)
instance USDable repr => USDable (JournalRepr repr) where
  usd (JournalReprAny x) = JournalReprAny (usd x)

instance
  ( Listable repr
  , Accountable repr
  , Amountable repr
  , Postable repr
  ) => Postable (JournalRepr repr) where
  post (JournalReprAny acct) (JournalReprAny amt) = JournalRepr $ JournalDo $
    MT.writer (TyPost, mempty{posts = post acct amt `cons` nil})
instance
  ( Addable (Ty repr TyQuantity)
  , Listable repr
  , Moveable repr
  , Negable (Ty repr TyQuantity)
  , Nullable (Ty repr TyQuantity)
  , Ord (Ty repr TyAccountSection)
  , Ord (Ty repr TyUnit)
  , Postable repr
  , Show (Ty repr TyAccountSection)
  , Show (Ty repr TyQuantity)
  , Show (Ty repr TyUnit)
  ) => Moveable (JournalRepr repr) where
  move (JournalRepr ps) = JournalRepr $ JournalDo $
    (`MT.mapWriterT` unJournalDo ps) $ fmap $ \(_ps, out) ->
      ( TyMove, out
        { moves = move (posts out) `cons` moves out
        , posts = nil
        }
      )

{-
instance FromInteger (JournalRepr acct amt repr AccountCode) where
  fromInteger i = JournalRepr do
    env <- MT.ask
    let ac = if 0 <= i then AccountCode (fromInteger i) else error ("Invalid AccountCode: "<>show i)
    case HashMap.lookup ac (accountByCode env) of
      Just{} -> return ac
      _ -> error ("Chart does not allow AccountCode: "<>show ac<>" "<>show (accountByCode env))
-}
--instance FromInteger qty => FromInteger (JournalRepr acct amt repr qty) where
--  fromInteger = JournalRepr . return . fromInteger
{-
type instance AccountSectionOf (ChartPath section) = section
type instance UnitOf (Map unit qty) = unit
type instance AmountOf () = Map Unit Q
type instance AccountOf () = NonEmpty AccountSegment

type Account = AccountCode
type AccountPath = ChartPath AccountSegment
type Amount = Map Unit Q
type Q = Quantity (Flow Decimal)

instance FromInteger qty => FromInteger (Flow qty) where
  fromInteger i | i <= 0 = Out (fromInteger i)
                | otherwise = In (fromInteger i)

instance
  Listable repr =>
  IsString (JournalRepr acct amt repr (ChartPath AccountSegment)) where
  fromString s = JournalRepr $ MT.ReaderT $ \env -> do
    case nonEmpty (fromString s) of
      Just acct | HashMap.member acct (accountByName env) -> MT.writer (acct, mempty)
      Just acct -> error ("AccountPath is not allowed by given Chart: "<>show acct)
      Nothing -> error "Invalid empty AccountPath"
instance
  Listable repr =>
  FromInteger (JournalRepr acct amt repr (ChartPath AccountSegment)) where
  fromInteger i = JournalRepr $ MT.ReaderT $ \env -> do
    let ac = if 0 <= i then AccountCode (fromInteger i) else error ("Invalid AccountCode: "<>show i)
    case HashMap.lookup ac (accountByCode env) of
      Just (Just acct, _) -> MT.writer (acct, mempty)
      _ -> error ("Chart does not allow AccountCode: "<>show ac<>" "<>show (accountByCode env))
instance
  Listable repr =>
  IsString (JournalRepr acct amt repr AccountCode) where
  fromString s = JournalRepr $ MT.ReaderT $ \env -> do
    case nonEmpty (fromString s) of
      Just acct | Just (ac, _) <- HashMap.lookup acct (accountByName env) -> MT.writer (ac, mempty)
      Just acct -> error ("AccountPath is not allowed by given Chart: "<>show acct)
      Nothing -> error "Invalid empty AccountPath"

-- ** Type 'JournalEnv'
data JournalEnv unit = JournalEnv
  { accountByCode :: HashMap.HashMap AccountCode (Maybe AccountPath, ChartNode)
  , accountByName :: HashMap.HashMap AccountPath (AccountCode, ChartNode)
  , defaultUnit :: unit
  }
journalEnv ch = JournalEnv
  { accountByCode = HashMap.fromList byCode
  , accountByName = HashMap.fromList byName
  , defaultUnit = inject ""
  } where
  (byCode, byName) = goChart (AccountCode 0, []) ch
  goChart p = Map.foldMapWithKey (goNode p) . unChart
  goNode (AccountCode kc, kn) n (node, children) =
    let keyCode = AccountCode (kc Prelude.* 10 Prelude.^ digitNumber n Prelude.+ n) in
    let keyName = kn <> maybeToList (sectionName node) in
    let (bc, bn) = goChart (keyCode, keyName) children in
    ( (keyCode, (nonEmpty keyName, node)) : bc
    , case nonEmpty keyName of
        Just k -> (k, (keyCode, node)) : bn
        Nothing -> bn
    )
instance
  ( FromInteger qty
  , Listable repr
  ) => FromInteger (JournalRepr acct (Map unit qty) repr (Map unit qty)) where
  fromInteger i = JournalRepr $
    --qty <- unJournalDo (fromInteger i :: JournalRepr acct (Map unit qty) repr qty)
    MT.writer (Map.singleton (defaultUnit env) (fromInteger i), mempty)

-- | @('digitNumber' n)@ retourne le nombre de digits nécessaires pour encoder 'n'.
digitNumber :: Natural -> Natural
digitNumber = go where
  go n | n < 10 = 1
       | otherwise = 1 Prelude.+ go (n`Prelude.div`10)

-}