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

-- import Data.Data (Data(..))
-- import Data.NonNull (NonNull)
-- import Data.String (IsString(..))
-- import Data.Text (Text)
-- import qualified Data.NonNull as NonNull
-- import qualified Data.Text as Text
-- import qualified System.FilePath.Posix as FP

import Data.Semigroup (Semigroup(..))
import Control.DeepSeq (NFData(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), flip)
import Data.Functor (Functor(..), (<$>))
import Data.Functor.Compose (Compose(..))
import Data.Map.Strict (Map)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Text (Text)
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 Data.Map.Strict as Map

import qualified Language.Symantic as Sym
import Language.Symantic.Grammar (At)

import qualified Hcompta as H
import Hcompta.LCC.Chart
import Hcompta.LCC.IO
import Hcompta.LCC.Posting


-- * Type 'Terms'
type Terms src = Map (Sym.Mod Sym.NameTe) (At src Text)
-- type Terms = [(Sym.Mod Sym.NameTe, Text)]

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

type instance MT.Element (Journal src j) = j
instance Functor (Journal src) where
	fmap f j@Journal{journal_content} =
		j{ journal_content = f journal_content }
instance MT.MonoFunctor (Journal src j)
instance Foldable (Journal src) where
	foldMap f Journal{journal_content} = f journal_content
instance MT.MonoFoldable (Journal src j)
instance Traversable (Journal src) where
	traverse f j = (\c -> j{journal_content=c}) <$> f (journal_content j)
instance Semigroup j => Semigroup (Journal src j) where
	x <> y =
		Journal
		 { journal_file           = journal_file y
		 , journal_last_read_time = journal_last_read_time x `min` journal_last_read_time y
		 , journal_includes       = journal_includes x <> journal_includes y
		 , journal_terms          = journal_terms    x <> journal_terms    y
		 , journal_chart          = journal_chart    x <> journal_chart    y
		 , journal_content        = journal_content  x <> journal_content  y
		 }
instance (Semigroup j, Monoid j) => Monoid (Journal src j) where
	mempty  = journal mempty
	mappend = (<>)
instance NFData j => NFData (Journal src j) where
	rnf Journal{..} =
		rnf journal_file `seq`
		rnf journal_last_read_time `seq`
		rnf journal_includes `seq`
		-- TODO: rnf journal_terms `seq`
		rnf journal_chart `seq`
		rnf journal_content

journal :: j -> Journal src j
journal j =
	Journal
	 { journal_file           = ""
	 , journal_last_read_time = H.epoch
	 , journal_includes       = []
	 , journal_chart          = mempty
	 , journal_terms          = mempty
	 , journal_content        = j
	 }

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

journal_union :: Semigroup j => Journal src j -> Journal src j -> Journal src 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 src j -> a -> a) -> Journal src 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 src j -> a -> m a) -> Journal src 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 src j -> a -> a) -> Journal src 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 src j -> Maybe a) -> Journal src j -> Maybe (a, [Journal src 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 src j -> Journal src j) -> Journal src j -> Journal src 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 src j -> Journal src j
journal_flatten jnl =
	(mconcat $ (:) jnl $ journal_flatten <$>
		journal_includes jnl) { journal_includes = [] }
-}

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

instance MT.MonoFunctor (Journals src j) where
	omap f (Journals m) = Journals $ f `MT.omap` m
instance MT.MonoFoldable (Journals src 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 src j) where
	otraverse f (Journals m) = Journals <$> MT.otraverse f m

instance Functor (Journals src) where
	fmap f (Journals m) = Journals $ fmap f <$> m
instance Foldable (Journals src) where
	foldMap f (Journals m) = f `foldMap` Compose m
instance Traversable (Journals src) where
	traverse f (Journals m) =
		Journals . getCompose <$> (f `traverse` Compose m)
instance Semigroup j => Semigroup (Journals src j) where
	Journals x <> Journals y = Journals $
		Map.unionWith (flip (<>)) x y
instance Semigroup j => Monoid (Journals src j) where
	mempty  = mempty
	mappend = (<>)




{-
-- ** 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)