{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.LCC.Journal where

-- import Data.NonNull (NonNull)
-- import Data.Text (Text)
-- import System.IO (IO)
-- import qualified Data.NonNull as NonNull
-- import qualified Data.Text as Text
-- import qualified System.Directory as IO
import Control.DeepSeq (NFData(..))
import Data.Data (Data(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor (Functor(..), (<$>))
import Data.Functor.Compose (Compose(..))
import Data.Map.Strict (Map)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.String (IsString(..))
import Data.Traversable (Traversable(..))
import Data.TreeMap.Strict (TreeMap)
import Data.Typeable (Typeable)
import Prelude (seq)
import Text.Show (Show(..))
import qualified Data.MonoTraversable as MT
import qualified System.FilePath.Posix as FP

{-
import Data.Tree
import Control.Monad (Monad(..), foldM)
import Data.List (reverse)
import Data.Maybe (Maybe(..))
import qualified Data.Monoid as Monoid
import Data.Semigroup (Semigroup(..))
-}

import qualified Hcompta as H
import Hcompta.LCC.Account
import Hcompta.LCC.Amount
import Hcompta.LCC.Chart
import Hcompta.LCC.Posting
import Hcompta.LCC.Transaction

-- * Type 'PathFile'
newtype PathFile = PathFile FP.FilePath
 deriving (Data, Eq, NFData, Ord, Show, Typeable)
instance IsString PathFile where
	fromString = PathFile

-- * Type 'CanonFile'
newtype CanonFile = CanonFile PathFile
 deriving (Data, Eq, NFData, Ord, Show, Typeable)

-- * Type 'Journal'
data Journal j
 =   Journal
 {   journal_file           :: !PathFile
 ,   journal_last_read_time :: !Date
 ,   journal_content        :: !j
 ,   journal_includes       :: ![CanonFile]
 } deriving (Data, Eq, Show, Typeable)

type instance MT.Element (Journal j) = j
instance Functor Journal where
	fmap f j@Journal{journal_content{- DELME: , journal_includes-}} =
		j{ journal_content = f journal_content
		 {- DELME: , journal_includes = fmap f <$> journal_includes-}
		 }
instance MT.MonoFunctor (Journal j)
instance Foldable Journal where
	foldMap f Journal{journal_content{- DELME: , journal_includes-}} =
		f journal_content {- DELME: `mappend`
		(foldMap f `foldMap` journal_includes)-}
instance MT.MonoFoldable (Journal j)
instance Traversable Journal where
	traverse f j = (\c -> j{journal_content=c}) <$> f (journal_content j)
instance NFData j => NFData (Journal j) where
	rnf Journal{..} =
		rnf journal_file `seq`
		rnf journal_last_read_time `seq`
		rnf journal_content `seq`
		rnf journal_includes

journal :: Monoid j => Journal j
journal =
	Journal
	 { journal_file           = ""
	 , journal_last_read_time = H.date_epoch
	 , journal_content        = mempty
	 , journal_includes       = []
	 }

{-
instance Semigroup j => Semigroup (Journal j) where
	(<>) = journal_union
instance (Monoid j, Semigroup j) => Monoid (Journal j) where
	mempty  = journal
	mappend = journal_union

journal_union :: Semigroup j => Journal j -> Journal j -> Journal j
journal_union x y =
	Journal
	 { journal_last_read_time = journal_last_read_time x `min` journal_last_read_time y
	 , journal_content        = journal_content        x <>    journal_content        y
	 , journal_includes       = journal_includes       x <>    journal_includes       y
	 }

journal_unions :: (Foldable f, Monoid j, Semigroup j) => f (Journal j) -> Journal j
journal_unions = foldl' (flip (<>)) journal
-}

{-
-- | Return the given accumulator folded over
--   the given 'Journal' and its 'journal_includes' 'Journal's.
journal_fold :: (Journal j -> a -> a) -> Journal j -> a -> a
journal_fold f j@Journal{journal_includes} a =
	foldl'
	 (flip $ journal_fold f) (f j a)
	 journal_includes

-- | Return the given accumulator folded over
--   the given 'Journal' and its 'journal_includes' 'Journal's.
journal_foldM :: Monad m => (Journal j -> a -> m a) -> Journal j -> a -> m a
journal_foldM f j@Journal{journal_includes} a = do
	ma <- f j a
	foldM
	 (flip $ journal_foldM f) ma
	 journal_includes

-- | Return the given accumulator folded with the given function
--   over the given 'Journal' and its 'journal_includes' 'Journal's.
journal_foldMap :: Monoid a => (Journal j -> a -> a) -> Journal j -> a -> a
journal_foldMap f j@(Journal{journal_includes}) =
	f j `mappend` foldMap (journal_foldMap f) journal_includes

-- | Return the first non-'Nothing' value returned by the given function
--   when applied to the given 'Journal' or its 'journal_includes' 'Journal's,
--   with the parent 'Journal's.
journal_find :: (Journal j -> Maybe a) -> Journal j -> Maybe (a, [Journal j])
journal_find f =
	(\x -> case x of
	 Nothing -> Nothing
	 Just (a, path) -> Just (a, reverse path))
	. find_ []
	where
		find_ path j =
			case f j of
			 Just a -> Just (a, path)
			 Nothing ->
				Monoid.getFirst $
				foldMap (Monoid.First . (find_ (j:path))) $
				journal_includes j

-- | Return the given 'Journal' and its 'journal_includes' 'Journal's
--   mapped by the given function.
journal_traverse :: (Journal j -> Journal j) -> Journal j -> Journal j
journal_traverse f =
	(\x -> case x of
	 j@Journal{journal_includes} ->
		j{journal_includes = journal_traverse f <$> journal_includes})
	. f

-- | Return the 'Journal' recursively 'mappend'-ed
--   with its 'journal_includes', now empty.
journal_flatten :: (Monoid j, Semigroup j) => Journal j -> Journal j
journal_flatten jnl =
	(mconcat $ (:) jnl $ journal_flatten <$>
		journal_includes jnl) { journal_includes = [] }
-}


-- * Type 'Compta'
data Compta
 =   Compta
 {   compta_chart         :: Chart
 ,   compta_journals      :: Journals (Map Date Transaction)
 ,   compta_style_amounts :: Style_Amounts
 -- ,   compta_code  :: Map Name Text
 }

-- * Type 'Journals'
newtype Journals j = Journals (Map CanonFile (Journal j))
 deriving (Data, Eq, Show, Typeable)
type instance MT.Element (Journals j) = Journal j

instance MT.MonoFunctor (Journals j) where
	omap f (Journals m) = Journals $ f `MT.omap` m
instance MT.MonoFoldable (Journals j) where
	ofoldMap f   (Journals m) = MT.ofoldMap f m
	ofoldr f a   (Journals m) = MT.ofoldr f a m
	ofoldl' f a  (Journals m) = MT.ofoldl' f a m
	ofoldr1Ex f  (Journals m) = MT.ofoldr1Ex f m
	ofoldl1Ex' f (Journals m) = MT.ofoldl1Ex' f m
instance MT.MonoTraversable (Journals j) where
	otraverse f (Journals m) = Journals <$> MT.otraverse f m

instance Functor Journals where
	fmap f (Journals m) = Journals $ fmap f <$> m
instance Foldable Journals where
	foldMap f (Journals m) = f `foldMap` Compose m
instance Traversable Journals where
	traverse f (Journals m) =
		Journals . getCompose <$> (f `traverse` Compose m)




{-
-- ** Type 'JournalFile'
newtype JournalFile = JournalFile PathFile
 deriving (Data, Eq, NFData, Ord, Show, Typeable)
unJournalFile :: JournalFile -> PathFile
unJournalFile (JournalFile fp) = fp

-- ** Type 'JournalFileCanon'
newtype JournalFileCanon = JournalFileCanon JournalFile
 deriving (Data, Eq, NFData, Ord, Show, Typeable)
unJournalFileCanon :: JournalFileCanon -> JournalFile
unJournalFileCanon (JournalFileCanon jf) = jf

journalFileCanon :: JournalFile -> IO JournalFileCanon
journalFileCanon (JournalFile (PathFile fp)) =
	JournalFileCanon . JournalFile . fromString
	 <$> IO.canonicalizePath fp

newtype Journals j = Journals (Forest (Journal j))
 deriving (Data, Eq, Show, Typeable)
type instance MT.Element (Journals j) = Journal j
instance MT.MonoFunctor (Journals j) where
	omap f (Journals m) = Journals $ f `MT.omap` m
instance MT.MonoFoldable (Journals j) where
	ofoldMap f   (Journals m) = MT.ofoldMap f m
	ofoldr f a   (Journals m) = MT.ofoldr f a m
	ofoldl' f a  (Journals m) = MT.ofoldl' f a m
	ofoldr1Ex f  (Journals m) = MT.ofoldr1Ex f m
	ofoldl1Ex' f (Journals m) = MT.ofoldl1Ex' f m
instance MT.MonoTraversable (Journals j) where
	otraverse f (Journals m) = Journals <$> MT.otraverse f m


instance Functor Journals where
	fmap f (Journals m) = Journals $
		getCompose $ getCompose . fmap f $ Compose (Compose m)
instance Foldable Journals where
	foldMap f (Journals m) = foldMap f $ Compose (Compose m)
instance Traversable Journals where
	traverse f (Journals m) =
		Journals . getCompose . getCompose
		 <$> traverse f (Compose (Compose m))

instance Functor Journals where
	fmap f (Journals m) = Journals $ fmap f <$> m
instance Foldable Journals where
	foldMap f (Journals m) = f `foldMap` Compose m
instance Traversable Journals where
	traverse f (Journals m) =
		Journals . getCompose <$> (f `traverse` Compose m)

journals_flatten :: Journals j -> Journal j
journals_flatten js@(Journals m)
	Map.fold
	MT.ofoldr1Ex (\j) js
-- | Return the 'Journal' recursively 'mappend'-ed
--   with its 'journal_includes', now empty.
journal_flatten :: (Monoid j, Semigroup j) => Journal j -> Journal j
journal_flatten jnl =
	(mconcat $ (:) jnl $ journal_flatten <$>
		journal_includes jnl) { journal_includes = [] }
-}

type instance MT.Element (TreeMap k a) = a
instance Ord k => MT.MonoFunctor     (TreeMap k a)
instance Ord k => MT.MonoFoldable    (TreeMap k a)
instance Ord k => MT.MonoTraversable (TreeMap k a)