{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableSuperClasses #-}
module Hcompta.LCC.Grammar where

import Control.Applicative (Applicative(..), liftA2)
import Control.Monad (Monad(..), void)
import Data.Bool
import Data.Char (Char)
import Data.Decimal
import Data.Either (Either(..), either)
import Data.Eq (Eq(..))
import Data.Foldable
import Data.Function (($), (.), const, id, flip)
import Data.Functor (Functor(..), (<$>), (<$))
import Data.Functor.Compose (Compose(..))
import Data.List.NonEmpty (NonEmpty(..), (<|))
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Monoid (Monoid(..))
import Data.NonNull (NonNull)
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Text (Text)
import Data.Time.LocalTime (TimeZone(..))
import Data.Traversable (sequenceA)
import Data.Tuple (fst)
import Data.Typeable (Typeable)
import Prelude (Int, Integer, Enum(..), Num(..), Integral(..), fromIntegral, error)
import System.FilePath ((</>))
import Text.Show (Show(..))
import qualified Control.Exception.Safe as Exn
import qualified Control.Monad.Classes as MC
import qualified Control.Monad.Trans.State.Strict as SS
import qualified Data.Char as Char
import qualified Data.List as L
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import qualified Data.NonNull as NonNull
import qualified Data.Strict as S
import qualified Data.Text as Text
import qualified Data.Time.Calendar  as Time
import qualified Data.Time.LocalTime as Time
import qualified Data.TreeMap.Strict as TreeMap
import qualified Hcompta as H
import qualified System.FilePath as FilePath

import qualified Language.Symantic.Grammar as G
import Language.Symantic.Grammar (CF, At(..), Gram_Rule(..), Gram_Terminal(..), Gram_Alt(..), Gram_AltApp(..), Gram_Try(..), Gram_CF(..))
import Language.Symantic.Lib ()
import qualified Language.Symantic as Sym
import qualified Language.Symantic.Grammar as Sym

import Hcompta.LCC.Account
import Hcompta.LCC.Amount
import Hcompta.LCC.Balance ()
import Hcompta.LCC.Chart
import Hcompta.LCC.Compta
import Hcompta.LCC.IO
import Hcompta.LCC.Journal
import Hcompta.LCC.Name
import Hcompta.LCC.Posting
import Hcompta.LCC.Tag
import Hcompta.LCC.Transaction

import qualified Hcompta.LCC.Lib.Strict as S

{-
import Debug.Trace (trace)
dbg :: Show a => String -> a -> a
dbg msg x = trace (msg <> " = " <> show x) x
-}

-- * Type 'Context_Read'
data Context_Read src =
 forall j. (Typeable j, H.Zeroable j) =>
   Context_Read
 { context_read_year          :: !Year
 , context_read_unit          :: !(S.Maybe Unit)
 , context_read_canonfiles    :: !(NonEmpty CanonFile)
 , context_read_warnings      :: ![At src Warning_Compta]
 , context_read_section       :: !Section
 
 , context_read_style_amounts :: !Style_Amounts
 , context_read_chart         :: !Chart
 , context_read_journals      :: !(Journals j)
 , context_read_journal       :: !(NonEmpty (Journal j))
 , context_read_consTxn       :: !(Transaction -> j -> j)
 } -- deriving (Eq, Show)

-- deriving instance Show src => Show (Context_Read src)

--
-- Readers
--

-- NonEmpty CanonFile
type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffReader (NonEmpty CanonFile)) = 'True
instance Monad m => MC.MonadReaderN 'MC.Zero (NonEmpty CanonFile) (S.StateT (Context_Read src) m) where
	askN _n = MC.gets $ \(x::Context_Read src) -> context_read_canonfiles x

--
-- States handled by a nested Monad
--
type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState (Sym.Imports ns, Sym.Modules src ss)) = 'False
type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState (Sym.Imports ns, Sym.ModulesTy src))  = 'False
type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState (Env src ss))                         = 'False
type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState Terms)                                = 'False

context_read ::
 Typeable j =>
 H.Zeroable j =>
 (Transaction -> j -> j) ->
 Context_Read src
context_read consTxn =
	Context_Read
	 { context_read_year          = Year $ H.yearOf (H.epoch::Date)
	 , context_read_style_amounts = mempty
	 , context_read_chart         = mempty
	 , context_read_unit          = S.Nothing
	 , context_read_journals      = Journals Map.empty
	 , context_read_journal       = journal H.zero :| []
	 , context_read_canonfiles    = CanonFile "" :| []
	 , context_read_warnings      = []
	 , context_read_section       = Section_Terms
	 , context_read_consTxn       = consTxn
	 }

-- * Type 'Context_Sym'
data Context_Sym src ss
 =   Context_Sym
 {   context_sym_imports   :: !(Sym.Imports Sym.NameTe)
 ,   context_sym_importsTy :: !(Sym.Imports Sym.NameTy)
 ,   context_sym_modules   :: !(Sym.Modules src ss)
 ,   context_sym_modulesTy :: !(Sym.ModulesTy src)
 ,   context_sym_env       :: !(Env src ss)
 ,   context_sym_terms     :: !Terms
 } deriving (Eq, Show)

context_sym ::
 forall src ss.
 Sym.Source src =>
 Sym.ImportTypes ss =>
 Sym.ModulesInj src ss =>
 Sym.ModulesTyInj ss =>
 Context_Sym src ss
context_sym =
	let mods = either (error . show) id Sym.modulesInj in
	Context_Sym
	 { context_sym_imports   = Sym.importModules [] mods
	 , context_sym_importsTy = Sym.importTypes @ss []
	 , context_sym_modules   = mods
	 , context_sym_modulesTy = Sym.modulesTyInj @ss
	 , context_sym_env       = Map.empty
	 , context_sym_terms     = Map.empty
	 }

--
-- States
--

-- (Sym.Imports Sym.NameTe, Sym.Modules src ss)
type instance MC.CanDo (S.StateT (Context_Sym src ss) m) (MC.EffState (Sym.Imports Sym.NameTe, Sym.Modules src ss)) = 'True
instance Monad m => MC.MonadStateN 'MC.Zero (Sym.Imports Sym.NameTe, Sym.Modules src ss) (S.StateT (Context_Sym src ss) m) where
	stateN _px f = S.StateT $ SS.state $ \ctx ->
		(\(imps, mods) -> ctx{context_sym_imports=imps, context_sym_modules=mods})
		 <$> f (context_sym_imports ctx, context_sym_modules ctx)

-- (Sym.Imports Sym.NameTy, Sym.ModulesTy src)
type instance MC.CanDo (S.StateT (Context_Sym src ss) m) (MC.EffState (Sym.Imports Sym.NameTy, Sym.ModulesTy src)) = 'True
instance Monad m => MC.MonadStateN 'MC.Zero (Sym.Imports Sym.NameTy, Sym.ModulesTy src) (S.StateT (Context_Sym src ss) m) where
	stateN _px f = S.StateT $ SS.state $ \ctx ->
		(\(imps, mods) -> ctx{context_sym_importsTy=imps, context_sym_modulesTy=mods})
		 <$> f (context_sym_importsTy ctx, context_sym_modulesTy ctx)

-- Terms
type instance MC.CanDo (S.StateT (Context_Sym src ss) m) (MC.EffState Terms) = 'True
instance Monad m => MC.MonadStateN 'MC.Zero Terms (S.StateT (Context_Sym src ss) m) where
	stateN _px f = S.StateT $ SS.state $ \ctx ->
		(\a -> ctx{context_sym_terms = a})
		 <$> f (context_sym_terms ctx)

-- Env src ss
type instance MC.CanDo (S.StateT (Context_Sym src ss) m) (MC.EffState (Env src ss)) = 'True
instance Monad m => MC.MonadStateN 'MC.Zero (Env src ss) (S.StateT (Context_Sym src ss) m) where
	stateN _px f = S.StateT $ SS.state $ \ctx ->
		(\a -> ctx{context_sym_env = a})
		 <$> f (context_sym_env ctx)

-- Context_Read src
type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState (Context_Read src)) = 'True
instance Monad m => MC.MonadStateN 'MC.Zero (Context_Read src) (S.StateT (Context_Read src) m) where
	stateN _px = S.StateT . SS.state

-- S.Maybe Unit
type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState (S.Maybe Unit)) = 'True
instance Monad m => MC.MonadStateN 'MC.Zero (S.Maybe Unit) (S.StateT (Context_Read src) m) where
	stateN _px f = S.StateT $ SS.state $ \ctx ->
		(\a -> ctx{context_read_unit = a})
		 <$> f (context_read_unit ctx)

-- Chart
type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState Chart) = 'True
instance Monad m => MC.MonadStateN 'MC.Zero Chart (S.StateT (Context_Read src) m) where
	stateN _px f = S.StateT $ SS.state $ \ctx ->
		(\a -> ctx{context_read_chart = a})
		 <$> f (context_read_chart ctx)

-- Year
type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState Year) = 'True
instance Monad m => MC.MonadStateN 'MC.Zero Year (S.StateT (Context_Read src) m) where
	stateN _px f = S.StateT $ SS.state $ \ctx ->
		(\a -> ctx{context_read_year = a})
		 <$> f (context_read_year ctx)

-- Section
type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState Section) = 'True
instance Monad m => MC.MonadStateN 'MC.Zero Section (S.StateT (Context_Read src) m) where
	stateN _px f = S.StateT $ SS.state $ \ctx ->
		(\a -> ctx{context_read_section = a})
		 <$> f (context_read_section ctx)

-- * Style_Amounts
type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState Style_Amounts) = 'True
instance Monad m => MC.MonadStateN 'MC.Zero Style_Amounts (S.StateT (Context_Read src) m) where
	stateN _px f = S.StateT $ SS.state $ \ctx ->
		(\s -> ctx{context_read_style_amounts = s})
		 <$> f (context_read_style_amounts ctx)

-- * Class 'Gram_Path'
class Gram_Path g where
	g_canonfile
	 :: g PathFile
	 -> g (PathFile, Either Exn.IOException CanonFile)
deriving instance Gram_Path g => Gram_Path (CF g)

-- * Class 'Gram_IO'
class G.Gram_Source src g => Gram_IO src g where
	g_read
	 :: g (S.Either (Error_Compta src) PathFile)
	 -> g (S.Either [At src (Error_Compta src)] a)
	 -> g (S.Either [At src (Error_Compta src)] a)
deriving instance Gram_IO src g => Gram_IO src (CF g)

-- * Class 'Gram_Count'
class
 ( G.Gram_App g
 , G.Gram_Alt g
 , G.Gram_AltApp g
 ) => Gram_Count g where
	count :: Int -> CF g a -> CF g [a]
	count n p
		| n <= 0    = pure []
		| otherwise = sequenceA $ L.replicate n p
	count' :: Int -> Int -> CF g a -> CF g [a]
	count' m n p
	 | n <= 0 || m > n = pure []
	 | m > 0 = (:) <$> p <*> count' (pred m) (pred n) p
	 | otherwise =
		let f t ts = maybe [] (:ts) t
		in f <$> G.optional p <*> count' 0 (pred n) p

-- * Class 'Gram_Char'
class
 ( G.Gram_Terminal g
 , G.Gram_Rule g
 , G.Gram_Alt g
 , G.Gram_AltApp g
 , G.Gram_Try g
 , G.Gram_App g
 , G.Gram_AltApp g
 , G.Gram_Comment g
 ) => Gram_Char g where
	g_eol :: CF g ()
	g_eol = rule "EOL" $ void (char '\n') <+> void (G.string "\r\n")
	g_tab :: CF g ()
	g_tab = rule "Tab" $ void $ char '\t'
	g_space :: CF g Char
	g_space = rule "Space" $ char ' '
	g_spaces :: CF g Text
	g_spaces = Text.pack <$> many g_space
	g_spaces1 :: CF g ()
	g_spaces1 = void $ some g_space
	g_char :: CF g Char
	g_char = g_char_passive <+> g_char_active
	g_char_passive :: CF g Char
	g_char_passive = choice $ G.unicat <$> [G.Unicat_Letter, G.Unicat_Number, G.Unicat_Mark]
	g_char_active :: CF g Char
	g_char_active = choice $ G.unicat <$> [G.Unicat_Punctuation, G.Unicat_Symbol]
	g_char_attribute :: G.Reg lr g Char
	g_char_attribute = choice $ char <$> "#/:;@~="
	g_word :: CF g Text
	g_word = rule "Word" $ Text.pack <$> some g_char
	g_words :: CF g Text
	g_words = Text.concat <$> many (try $ (<>) <$> g_spaces <*> g_word)
	g_09 :: CF g Char
	g_09 = range ('0', '9')
	g_19 :: CF g Char
	g_19 = range ('1', '9')
	g_sign :: Num int => CF g (int -> int)
	g_sign =
		(negate <$ char '-') <+>
		(id     <$ char '+')

-- * Class 'Gram_Date'
class
 ( G.Gram_State Year g
 , G.Gram_Terminal g
 , G.Gram_Rule g
 , G.Gram_Alt g
 , G.Gram_Try g
 , G.Gram_App g
 , G.Gram_AltApp g
 , Gram_Char g
 , Gram_Count g
 ) => Gram_Date g where
	g_date ::
	 G.Gram_Source src g =>
	 CF g (S.Either (At src Error_Date) Date)
	g_date = rule "Date" $
		liftA2 (\day (tod, tz) ->
			Time.localTimeToUTC tz $
			Time.LocalTime day tod)
		 <$> g_ymd
		 <*> option
			 (S.Right (Time.midnight, Time.utc))
			 (liftA2 (,)
				 <$ char '_'
				 <*> g_tod
				 <*> option (S.Right Time.utc) g_timezone)
	g_ymd ::
	 G.Gram_Source src g =>
	 CF g (S.Either (At src Error_Date) Time.Day)
	g_ymd = rule "YMD" $
		G.source $
		try (mk_ymd
		 <$> g_year
		 <*  char char_ymd_sep
		 <*> g_month
		 <*  char char_ymd_sep
		 <*> g_dom)
		<+>
		mk_ymd
		 <$> G.getAfter (pure $ \(Year y) -> y)
		 <*> g_month
		 <*  char char_ymd_sep
		 <*> g_dom
		where
		mk_ymd y m d src =
			case Time.fromGregorianValid y m d of
			 Nothing  -> S.Left $ At src $ Error_Date_Day_invalid (y, m, d)
			 Just day -> S.Right day
	g_tod ::
	 G.Gram_Source src g =>
	 CF g (S.Either (At src Error_Date) Time.TimeOfDay)
	g_tod = rule "TimeOfDay" $
		G.source $
		(\hr (mn, sc) src ->
			case Time.makeTimeOfDayValid hr mn (fromInteger $ toInteger sc) of
			 Nothing -> S.Left $ At src $ Error_Date_TimeOfDay_invalid (hr, mn, sc)
			 Just tod -> S.Right $ tod)
		 <$> g_hour
		 <*> option (0, 0)
			((,)
			 <$> (char char_tod_sep *> g_minute)
			 <*> option 0 (char char_tod_sep *> g_second))
	g_year :: CF g Integer
	g_year = rule "Year" $
		(\sg y -> sg $ integer_of_digits 10 y)
		 <$> option id (negate <$ char '-')
		 <*> some g_09
	g_month :: CF g Int
	g_month = rule "Month" $ int_of_digits 10 <$> count' 1 2 g_09
	g_dom :: CF g Int
	g_dom = rule "DayOfMonth" $ int_of_digits 10 <$> count' 1 2 g_09
	g_hour :: CF g Int
	g_hour = rule "Hour" $ int_of_digits 10 <$> count' 1 2 g_09
	g_minute :: CF g Int
	g_minute = rule "Minute" $ int_of_digits 10 <$> count' 1 2 g_09
	g_second :: CF g Int
	g_second = rule "Second" $ int_of_digits 10 <$> count' 1 2 g_09
	
	g_timezone ::
	 G.Gram_Source src g =>
	 CF g (S.Either (At src Error_Date) TimeZone)
	g_timezone = rule "TimeZone" $
		-- DOC: http://www.timeanddate.com/time/zones/
		-- TODO: only a few time zones are suported below.
		-- TODO: check the timeZoneSummerOnly values
		(S.Right <$> g_timezone_digits) <+>
		(G.source $ read_tz <$ char '_' <*> some (range ('A', 'Z')))
		where
		read_tz n src = case n of
		 "AST"  -> S.Right $ TimeZone (- 4 * 60) False n
		 "ADT"  -> S.Right $ TimeZone (- 3 * 60) True  n
		 "A"    -> S.Right $ TimeZone (- 1 * 60) False n
		 "BST"  -> S.Right $ TimeZone (-11 * 60) False n
		 "BDT"  -> S.Right $ TimeZone (-10 * 60) True  n
		 "CET"  -> S.Right $ TimeZone (  1 * 60) True  n
		 "CEST" -> S.Right $ TimeZone (  2 * 60) False n
		 "CST"  -> S.Right $ TimeZone (- 6 * 60) False n
		 "CDT"  -> S.Right $ TimeZone (- 5 * 60) True  n
		 "EST"  -> S.Right $ TimeZone (- 5 * 60) False n
		 "EDT"  -> S.Right $ TimeZone (- 4 * 60) True  n
		 "GMT"  -> S.Right $ TimeZone    0       False n
		 "HST"  -> S.Right $ TimeZone (-10 * 60) False n
		 "HDT"  -> S.Right $ TimeZone (- 9 * 60) True  n
		 "MST"  -> S.Right $ TimeZone (- 7 * 60) False n
		 "MDT"  -> S.Right $ TimeZone (- 6 * 60) True  n
		 "M"    -> S.Right $ TimeZone (-12 * 60) False n
		 "NST"  -> S.Right $ TimeZone (- 3 * 60 - 30) False n
		 "N"    -> S.Right $ TimeZone (  1 * 60) False n
		 "PST"  -> S.Right $ TimeZone (- 8 * 60) False n
		 "PDT"  -> S.Right $ TimeZone (- 7 * 60) True  n
		 "YST"  -> S.Right $ TimeZone (- 9 * 60) False n
		 "YDT"  -> S.Right $ TimeZone (- 8 * 60) True  n
		 "Y"    -> S.Right $ TimeZone ( 12 * 60) False n
		 "Z"    -> S.Right $ TimeZone    0       False n
		 _      -> S.Left  $ At src $ Error_Date_TimeZone_unknown (Text.pack n)
	g_timezone_digits :: CF g TimeZone
	g_timezone_digits =
		(\sg hr mn ->
			let tz =
				TimeZone
				 { timeZoneMinutes    = sg $ hr * 60 + mn
				 , timeZoneSummerOnly = False
				 , timeZoneName       = Time.timeZoneOffsetString tz
				 }
			in tz)
		 <$> g_sign
		 <*> g_hour
		 <*> option 0 (optional (char char_tod_sep) *> g_minute)

-- * Class 'Gram_Tag'
class
 ( Gram_Char g
 , G.Gram_Terminal g
 , G.Gram_Try g
 , G.Gram_CF g
 ) => Gram_Tag g where
	g_tag :: CF g Tag
	g_tag = Tag
		 <$  char char_tag_prefix
		 <*> g_tag_path
		 <*> option (Tag_Data "")
			 ( try $ g_spaces
			 *> char char_tag_data_prefix
			 *> g_spaces
			 *> g_tag_value )
	g_tag_path :: CF g Tag_Path
	g_tag_path =
		(\x xs -> Tag_Path $ NonNull.ncons x xs)
		 <$> g_tag_section
		 <*> many (try $ char char_tag_sep *> g_tag_section)
	g_tag_section :: CF g Tag_Path_Section
	g_tag_section =
		Name . Text.pack
		 <$> some (g_char `minus` g_char_attribute)
	g_tag_value :: CF g Tag_Data
	g_tag_value = Tag_Data <$> g_words

-- * Class 'Gram_Comment'
class
 ( G.Gram_Terminal g
 , Gram_Char g
 ) => Gram_Comment g where
	g_comment :: CF g Comment
	g_comment = rule "Comment" $
		Comment <$ char ';' <* g_spaces <*> g_words

-- * Class 'Gram_Account'
class
 ( G.Gram_Try g
 , Gram_Char g
 , Gram_Comment g
 , Gram_Tag g
 ) => Gram_Account g where
	g_account_section :: CF g NameAccount
	g_account_section =
		Name . Text.pack
		 <$> some (g_char `minus` g_char_attribute)
	g_account :: CF g Account
	g_account = rule "Account" $
		Account . NonNull.impureNonNull
		 <$> some (try $ char '/' *> g_account_section)
	g_account_tag :: CF g Account_Tag
	g_account_tag =
		(Account_Tag <$>) $
		Tag
		 <$  char char_account_tag_prefix
		 <*> g_tag_path
		 <*> option (Tag_Data "")
			 (try $ g_spaces
			 *> char char_tag_data_prefix
			 *> g_spaces
			 *> g_tag_value )
	g_account_tag_path :: CF g Tag_Path
	g_account_tag_path = rule "Tag_Path" $
		char char_account_tag_prefix
		 *> g_tag_path
	{-
	g_anchor_section :: CF g Anchor_Section
	g_anchor_section = rule "Anchor_Section" $
		Name . Text.pack
		 <$> some (g_char `minus` g_char_attribute)
	-}

-- * Class 'Gram_Amount'
class
 ( Gram_Char g
 , G.Gram_Terminal g
 , G.Gram_CF g
 ) => Gram_Amount g where
	g_unit :: CF g Unit
	g_unit = rule "Unit" $
		Unit . Text.singleton
		 <$> G.unicat (G.Unicat Char.CurrencySymbol)
	g_quantity :: CF g (Quantity, Style_Amount)
	g_quantity = rule "Quantity" $
		(\(i, f, fr, gi, gf) ->
			let int  = concat i in
			let frac = concat f in
			let precision = length frac in
			-- guard (precision <= 255)
			let mantissa = integer_of_digits 10 $ int <> frac in
			( Decimal
				 (fromIntegral precision)
				 mantissa
			, mempty
				 { style_amount_fractioning=fr
				 , style_amount_grouping_integral=gi
				 , style_amount_grouping_fractional=gf
				 }
			))
		 <$> choice (try <$>
			 [ g_qty '_' ',' '_' <* (pure () `minus` choice (char <$> ",._"))
			 , g_qty '_' '.' '_' <* (pure () `minus` choice (char <$> ",._"))
			 , g_qty ',' '.' '_' <* (pure () `minus` choice (char <$> ",._"))
			 , g_qty '.' ',' '_' <* (pure () `minus` choice (char <$> ",._"))
			 ])
	g_qty
	 :: Char -- ^ Integral grouping separator.
	 -> Char -- ^ Fractioning separator.
	 -> Char -- ^ Fractional grouping separator.
	 -> CF g
	 ( [String] -- integral
	 , [String] -- fractional
	 , S.Maybe Style_Amount_Fractioning -- fractioning
	 , S.Maybe Style_Amount_Grouping -- grouping_integral
	 , S.Maybe Style_Amount_Grouping -- grouping_fractional
	 )
	g_qty int_group_sep frac_sep frac_group_sep =
		(\int mf ->
			case mf of
			 Nothing ->
				( int
				, []
				, S.Nothing
				, grouping_of_digits int_group_sep int
				, S.Nothing
				)
			 Just (fractioning, frac) ->
				( int
				, frac
				, S.Just fractioning
				, grouping_of_digits int_group_sep int
				, grouping_of_digits frac_group_sep $ L.reverse frac
				))
		 <$> ((:)
			 <$> some g_09
			 <*> option [] (many $ try $ char int_group_sep *> some g_09))
		 <*> option Nothing (Just <$> ((,)
			 <$> char frac_sep
			 <*> ((:)
				 <$> many g_09
				 <*> option [] (many $ try $ char frac_group_sep *> some g_09))))
		where
			grouping_of_digits :: Char -> [String] -> S.Maybe Style_Amount_Grouping
			grouping_of_digits group_sep digits =
				case digits of
				 []  -> S.Nothing
				 [_] -> S.Nothing
				 _   -> S.Just $
					Style_Amount_Grouping group_sep $
					canonicalize_grouping $
					length <$> digits
			canonicalize_grouping :: [Int] -> [Int]
			canonicalize_grouping groups =
				foldl' -- NOTE: remove duplicates at beginning and reverse.
				 (\acc l0 -> case acc of
					 l1:_ -> if l0 == l1 then acc else l0:acc
					 _ -> l0:acc) [] $
				case groups of -- NOTE: keep only longer at beginning.
				 l0:l1:t -> if l0 > l1 then groups else l1:t
				 _ -> groups
	
	g_amount :: CF g (Styled_Amount Amount)
	g_amount = rule "Amount" $ g_amount_minus <+> g_amount_plus
	g_amount_minus :: CF g (Styled_Amount Amount)
	g_amount_minus =
		char '-' *> (
			mk_amount L
			 <$> ((,) <$> g_unit <*> g_spaces)
			 <*> g_quantity
			<+>
			flip (mk_amount R)
			 <$> g_quantity
			 <*> option ("", "")
				 (try $ flip (,) <$> g_spaces <*> g_unit) )
		<+>
		try (mk_amount L
		 <$> ((,) <$> g_unit <*> g_spaces)
		 <*  char '-'
		 <*> g_quantity)
		where
		mk_amount :: LR -> (Unit, Text) -> (Quantity, Style_Amount) -> (Style_Amount, Amount)
		mk_amount side (unit, sp) (qty, sty) =
			( case unit of
			 Unit "" -> sty
			 _ -> sty
				{ style_amount_unit_side   = S.Just side
				, style_amount_unit_spaced = S.Just $ not $ Text.null sp
				}
			, Amount
				{ amount_quantity = negate qty
				, amount_unit     = unit
				}
			)
	g_amount_plus :: CF g (Styled_Amount Amount)
	g_amount_plus =
		char '+' *> (
			mk_amount L
			 <$> ((,) <$> g_unit <*> g_spaces)
			 <*> g_quantity
			<+>
			flip (mk_amount R)
			 <$> g_quantity
			 <*> option ("", "")
				 (try $ flip (,) <$> g_spaces <*> g_unit) )
		<+>
		mk_amount L
		 <$> ((,) <$> g_unit <*> g_spaces)
		 <*  optional (char '+')
		 <*> g_quantity
		<+>
		flip (mk_amount R)
		 <$> g_quantity
		 <*> option ("", "")
			 (try $ flip (,) <$> g_spaces <*> g_unit)
		where
		mk_amount :: LR -> (Unit, Text) -> (Quantity, Style_Amount) -> (Style_Amount, Amount)
		mk_amount side (unit, sp) (qty, sty) =
			( case unit of
			 Unit "" -> sty
			 _ -> sty
				{ style_amount_unit_side   = S.Just side
				, style_amount_unit_spaced = S.Just $ not $ Text.null sp
				}
			, Amount
				{ amount_quantity = qty
				, amount_unit     = unit
				}
			)

-- * Class 'Gram_Posting'
class
 ( Gram_Account g
 , Gram_Amount g
 , Gram_Char g
 , Gram_Comment g
 , G.Gram_Reader SourcePos g
 , G.Gram_State (S.Maybe Unit) g
 , G.Gram_State Chart g
 , G.Gram_State Style_Amounts g
 , G.Gram_Terminal g
 ) => Gram_Posting g where
	g_postings ::
	 G.Gram_Source src g =>
	 CF g (S.Either (At src Error_Posting) [Posting])
	g_postings =
		fmap sequenceA $
		many $ try $
			many (try $ g_spaces *> g_eol) *>
			g_spaces1 *> g_posting
	g_posting ::
	 G.Gram_Source src g =>
	 CF g (S.Either (At src Error_Posting) Posting)
	g_posting = rule "Posting" $
		G.stateAfter $ G.getAfter $ G.askBefore $
		(\lr_acct
		 may_amt attrs
		  posting_sourcepos ctx_unit
		 (Style_Amounts ctx_stys) -> do
			let (posting_tags, posting_comments) = attrs
			let (stys, posting_amounts) =
				case may_amt of
				 Nothing -> (Style_Amounts ctx_stys, mempty)
				 Just (sty, amt) ->
					let ctx =
						Style_Amounts $
						Map.insertWith (flip (<>))
						 (amount_unit amt)
						 sty ctx_stys in
					let unit =
						case amount_unit amt of
						 u | u == "" -> S.fromMaybe u ctx_unit
						 u -> u in
					(ctx,) $
						Amounts $
						Map.singleton unit $
						amount_quantity amt
			(stys,) $ do
				(posting_account, posting_account_ref) <- lr_acct
				S.Right $
					Posting
					 { posting_account
					 , posting_account_ref
					 , posting_amounts
					 , posting_tags
					 , posting_comments
					 , posting_dates = []
					 , posting_sourcepos
					 })
		 <$> g_posting_account
		 <*> optional (try $ g_spaces1 *> g_amount)
		 <*> g_posting_attrs
	g_posting_account ::
	 G.Gram_Source src g =>
	 CF g (S.Either (At src Error_Posting)
	                (Account, S.Maybe (S.Pair Tag_Path (S.Maybe Account))))
	g_posting_account = rule "Posting_Account" $
		(S.Right . (, S.Nothing) <$> g_account) <+>
		(mk_posting_account
			 <$> (G.source $ G.getAfter $ expand_tag_path <$> g_account_tag_path)
			 <*> option S.Nothing (S.Just <$> g_account))
		where
		mk_posting_account path acct =
			(\(p, a) ->
				(,)
				 (S.maybe a (a <>) acct)
				 (S.Just (p S.:!: acct)) )
			 <$> path
		expand_tag_path tag chart src =
			case Map.lookup tag $ chart_tags chart of
			 Just accts | Map.size accts > 0 ->
				if Map.size accts == 1
				then
					let acct = fst $ Map.elemAt 0 accts in
					S.Right (tag, acct)
				else S.Left $ At src $ Error_Posting_Account_Ref_multiple tag accts
			 _ ->  S.Left $ At src $ Error_Posting_Account_Ref_unknown tag
	g_posting_tag :: CF g Posting_Tag
	g_posting_tag = rule "Posting_Tag" $ Posting_Tag <$> g_tag
	g_posting_attrs :: CF g (Posting_Tags, [Comment])
	g_posting_attrs =
		foldr ($) mempty . Compose
		 <$> (many $ try $
			many (try $ g_spaces *> g_eol *> g_spaces1) *>
			some (try $
				g_spaces *>
				choice
				 [ add_tag     <$> g_posting_tag
				 , add_comment <$> g_comment
				 ]))
		where
		add_tag (Posting_Tag (Tag (Tag_Path p) v)) =
			\(Posting_Tags (Tags tags), cmts) ->
				( Posting_Tags (Tags (TreeMap.insert (<>) p [v] tags))
				, cmts )
		add_comment c =
			\(tags, cmts) ->
				(tags, c:cmts)

-- * Class 'Gram_Transaction'
class
 ( Gram_Account g
 , Gram_Amount g
 , Gram_Char g
 , Gram_Comment g
 , Gram_Date g
 , Gram_Posting g
 , G.Gram_Terminal g
 , G.Gram_State Section g
 ) => Gram_Transaction g where
	g_transaction ::
	 G.Gram_Source src g =>
	 CF g (S.Either (At src Error_Transaction) Transaction)
	g_transaction = rule "Transaction" $
		G.stateAfter $ (update_year <$>) $
		G.source $ G.askBefore $
		(\lr_date
		 transaction_wording
		 ( transaction_tags
		 , transaction_comments )
		 lr_posts
		 transaction_sourcepos src -> do
			date  <- fmap Error_Transaction_Date    `S.left` lr_date
			posts <- fmap Error_Transaction_Posting `S.left` lr_posts
			let postsByAcct = postings_by_account posts
			let txn =
				Transaction
				 { transaction_tags
				 , transaction_comments
				 , transaction_dates = NonNull.ncons date []
				 , transaction_wording
				 , transaction_postings = Postings postsByAcct
				 , transaction_sourcepos
				 }
			case H.equilibrium postsByAcct of
			 (_, Left ko) -> S.Left $ At src $ Error_Transaction_not_equilibrated txn ko
			 (_bal, Right ok) -> S.Right txn{transaction_postings = Postings ok}
		 )
		 <$> g_date
		 <*  g_spaces1
		 <*> g_wording
		 <*> g_transaction_attrs
		 <*> g_postings
		where
		update_year lr_txn y =
			(,lr_txn) $
			case lr_txn of
			 S.Right txn -> Year $ H.yearOf $ NonNull.head $ transaction_dates txn
			 _ -> y
	g_wording :: CF g Wording
	g_wording = rule "Wording" $
		Wording . Text.concat
		 <$> many (try $
			(<>)
			 <$> g_spaces
			 <*> (Text.pack
				 <$> some (g_char `minus` char char_tag_prefix)))
	g_transaction_tag :: CF g Transaction_Tag
	g_transaction_tag = rule "Transaction_Tag" $ Transaction_Tag <$> g_tag
	g_transaction_attrs :: CF g (Transaction_Tags, [Comment])
	g_transaction_attrs =
		foldr ($) mempty
		 <$> many (
			choice (try <$>
			 [ add_tag     <$ many (try $ g_spaces *> g_eol *> g_spaces1) <*> g_transaction_tag
			 , add_comment <$ many (try $ g_spaces *> g_eol *> g_spaces)  <*> g_comment
			 ]))
		where
		add_tag (Transaction_Tag (Tag (Tag_Path p) v)) =
			\(Transaction_Tags (Tags tags), cmts) ->
				( Transaction_Tags (Tags (TreeMap.insert (<>) p [v] tags))
				, cmts )
		add_comment c =
			\(tags, cmts) ->
				(tags, c:cmts)

-- * Class 'Gram_File'
class
 ( Gram_Char g
 , G.Gram_Rule g
 , G.Gram_Terminal g
 , G.Gram_Try g
 , G.Gram_CF g
 ) => Gram_File g where
	g_pathfile :: CF g PathFile
	g_pathfile = rule "PathFile" $
		PathFile . concat
		 <$> some (try $ (:) <$> char '/' <*> some (g_char `minus` char '/'))

-- * Class 'Gram_Chart'
class
 ( Gram_Account g
 , Gram_Comment g
 , G.Gram_Try g
 ) => Gram_Chart g where
	g_chart_entry ::
	 G.Gram_Source src g =>
	 CF g (S.Either (At src (Error_Compta src)) Chart)
	g_chart_entry = rule "Chart" $
		(\acct attrs ->
			let (tags, tags2, _comments) = attrs in
			S.Right $
			Chart
			 { chart_accounts = TreeMap.singleton (H.to acct) tags
			 , chart_tags     = Map.singleton acct () <$ tags2
			 }
		 )
		 <$> g_account
		 <*> g_chart_attrs
	g_chart_attrs :: CF g (Account_Tags, Map Tag_Path (), [Comment])
	g_chart_attrs =
		foldr ($) mempty
		 <$> (many $ try $
			many (try $ g_spaces *> g_eol) *>
			choice
			 [ add_tag     <$ g_spaces1 <*> g_account_tag
			 , add_comment <$ g_spaces  <*> g_comment
			 ])
		where
		add_tag (Account_Tag (Tag (Tag_Path p) v)) =
			\(Account_Tags (Tags tags), tags2, cmts) ->
				( Account_Tags (Tags (TreeMap.insert (<>) p [v] tags))
				, Map.insert (Tag_Path p) () tags2
				, cmts )
		add_comment c =
			\(tags, tags2, cmts) ->
				(tags, tags2, c:cmts)

-- * Class 'Gram_Input'
class Gram_Input g where
	g_input :: g (Text -> a) -> g a
deriving instance Gram_Input g => Gram_Input (CF g)

-- * Class 'Gram_Term_Def'
class
 ( G.Gram_Source src g
 , Sym.Gram_Term src ss g
 , G.SourceInj (Sym.TypeVT src) src
 , G.SourceInj (Sym.KindK src) src
 , G.SourceInj (Sym.AST_Type src) src
 ) => Gram_Term_Def src ss g where
	g_term_def :: CF g (S.Either (At src (Sym.NameTe, Sym.Error_Term src)) (Sym.NameTe, Sym.TermVT src ss '[]))
	g_term_def = rule "TermDef" $
		G.source $
		(\n args v src ->
			let lr_t =
				Sym.readTerm Sym.CtxTyZ $
				foldr (\(x, ty_x) -> G.BinTree0 . Sym.Token_Term_Abst src x ty_x) v args in
			case lr_t of
			 Right t  -> S.Right (n, t)
			 Left err -> S.Left $ At src (n, err)
		 )
		 <$> Sym.g_NameTe
		 <*> many Sym.g_term_abst_decl
		 <*  Sym.symbol "="
		 <*> Sym.g_term

-- * Class 'Gram_Compta'
class
 ( G.Gram_Source src g
 , G.Gram_Try g
 , Gram_Account g
 , Gram_Chart g
 , Gram_File g
 , Gram_Path g
 , Gram_IO src g
 , Gram_Comment g
 , Gram_Transaction g
 , Gram_Term_Def src ss g
 , G.Gram_Reader (S.Either Exn.IOException CanonFile) g
 , G.Gram_State (Context_Read src) g
 , G.Gram_State (Sym.Imports Sym.NameTe, Sym.Modules src ss) g
 -- , G.Gram_State (Journal j) g
 -- , G.Gram_State (Journals j) g
 , G.Gram_State Terms g
 , Gram_Input g
 -- , H.Zeroable j
 -- , Show src
 ) => Gram_Compta ss src g where
	g_compta :: CF g (S.Either [At src (Error_Compta src)] CanonFile)
	g_compta = rule "Journal" $
		G.stateAfter $ G.askBefore $
		mk_journal
		 <$> (G.stateAfter $ G.source $ G.askBefore $ G.askBefore $ pure init_journal)
		 <*> many (choice
			 [ G.stateAfter $ mk_include <$> g_include @ss
			 -- NOTE: g_include must be the first choice
			 -- in order to have Megaparsec reporting the errors
			 -- of the included journal.
			 , G.stateAfter $ mk_transaction
				 <$> g_compta_section Section_Transactions g_transaction
			 , G.stateAfter $ mk_chart
				 <$> g_compta_section Section_Chart g_chart_entry
			 , G.stateBefore $ G.stateBefore $ g_input $ G.source $ mk_term
				 <$> g_compta_section Section_Terms g_term_def
			 , ([], []) <$ try (g_spaces <* g_eol)
			 ])
		where
		init_journal
		 (SourcePos jf _ _) lr_cf src
		 (ctx@Context_Read
			 { context_read_journals   = Journals js
			 , context_read_journal    = jnls
			 , context_read_canonfiles = cfs
			 , ..
			 }::Context_Read src) =
			case lr_cf of
			 S.Left e -> (ctx, S.Left $ At src $ Error_Compta_Read (PathFile jf) e)
			 S.Right cf ->
				let jnl = (journal H.zero){journal_file=PathFile jf} in
				(,S.Right ())
				Context_Read
				 { context_read_journals   = Journals $ Map.insert cf jnl js
				 , context_read_journal    = jnl <| jnls
				 , context_read_canonfiles = cf  <| cfs
				 , ..
				 }
		mk_journal err errs_warns
		 (SourcePos jf _ _)
		 (ctx@Context_Read
			 { context_read_journals   = Journals js
			 , context_read_journal    = jnl :| jnls
			 , context_read_canonfiles = cf  :| cfs
			 , context_read_warnings   = warnings
			 , ..
			 }::Context_Read src) =
			let (errs, warns) = L.unzip errs_warns in
			case S.either pure (const []) err <> L.concat errs of
			 [] ->
				let jnl' = jnl{journal_file=PathFile jf} in
				(,S.Right cf)
				Context_Read
				 { context_read_journals   = Journals $ Map.insert cf jnl' js
				 , context_read_journal    = NonEmpty.fromList jnls
				 , context_read_canonfiles = NonEmpty.fromList cfs
				 , context_read_warnings   = warnings <> L.concat warns
				 , ..
				 }
			 es -> (ctx, S.Left es)
		mk_transaction lr_txn
		 (ctx@Context_Read
			 { context_read_journal = j :| js
			 , context_read_consTxn
			 , ..
			 }::Context_Read src) =
			case lr_txn of
			 S.Left err  -> (ctx, ([err], []))
			 S.Right txn -> (, ([], [])) Context_Read
				 { context_read_journal = j{journal_content = txn `context_read_consTxn` journal_content j} :| js
				 , ..
				 }
		
		mk_include lr_inc
		 (ctx@Context_Read
			 { context_read_journal = j :| js
			 , context_read_consTxn
			 , ..
			 }::Context_Read src) =
			case lr_inc of
			 S.Left errs -> (ctx, (errs, []))
			 S.Right cf -> (, ([], [])) Context_Read
				 { context_read_journal = j{journal_includes = journal_includes j <> [cf]} :| js
				 , ..
				 }
		mk_chart lr_ch chart =
			case lr_ch of
			 S.Left err -> (chart, ([err], []))
			 S.Right ch -> (chart <> ch, ([], []))
		mk_term lr_te src body (imps::Sym.Imports Sym.NameTe, mods) =
			case lr_te of
			 S.Left err      -> ((imps, mods), (, ([err], [])))
			 S.Right (n, te) -> ((imps, ins_term n te mods), \ts -> (ins_body n body ts, ([], warn_redef n ts)))
			where
			ins_term :: Sym.NameTe -> Sym.TermVT src ss '[] -> Sym.Modules src ss -> Sym.Modules src ss
			ins_term n t = Sym.insertTermVT ([] `Sym.Mod` t) n (Sym.Fixity2 Sym.infixN5)
			ins_body :: Sym.NameTe -> Text -> Terms -> Terms
			ins_body n = Map.insert ([] `Sym.Mod` n)
			warn_redef :: Sym.NameTe -> Terms -> [At src Warning_Compta]
			warn_redef n ts =
				case Map.lookup ([] `Sym.Mod` n) ts of
				 Just{} -> [At src $ Warning_Compta_Term_redefined n]
				 Nothing -> []
	g_include :: CF g (S.Either [At src (Error_Compta src)] CanonFile)
	g_include = rule "Include" $
		g_read g_path (g_compta @ss <* G.eoi)
		where
		g_path =
			G.stateAfter $ G.source $ check_path
			 <$> (g_canonfile $ G.askBefore $ fmap mk_path $
				(\d (PathFile p) -> PathFile $ d:p)
				 <$> char '.' <*> g_pathfile)
		mk_path (PathFile fp) (SourcePos fp_old _ _) =
			PathFile $
			FilePath.normalise $
			FilePath.takeDirectory fp_old </> fp
		check_path (fp, lr_cf) src
		 (ctx@Context_Read
			 { context_read_journals   = Journals js
			 , context_read_canonfiles = cfs
			 , context_read_warnings   = warns
			 }::Context_Read src) =
			case lr_cf of
			 Left e -> (ctx, S.Left $ Error_Compta_Read fp e)
			 Right cf ->
				if cf `Map.member` js
				then
					if cf `elem` cfs
					then (ctx, S.Left $ Error_Compta_Include_loop cf)
					else
						(,S.Right fp) $
						if isJust $ (`L.find` warns) $ \case
						 At{unAt=Warning_Compta_Include_multiple cf'} -> cf' `elem` cf<|cfs
						 _ -> False
						then ctx
						else ctx
						 { context_read_warnings =
							At src (Warning_Compta_Include_multiple cf) : warns }
				else (ctx, S.Right fp)

-- * Integers

-- | Return the 'Integer' obtained by multiplying the given digits
--   with the power of the given base respective to their rank.
integer_of_digits
 :: Integer -- ^ Base.
 -> String  -- ^ Digits (MUST be recognised by 'Char.digitToInt').
 -> Integer
integer_of_digits base =
	foldl' (\x d -> base*x + toInteger (Char.digitToInt d)) 0

-- | Return the 'Int' obtained by multiplying the given digits
--   with the power of the given base respective to their rank.
int_of_digits
 :: Int -- ^ Base.
 -> String -- ^ Digits (MUST be recognised by 'Char.digitToInt').
 -> Int
int_of_digits base =
	foldl' (\x d -> base*x + Char.digitToInt d) 0

-- * Chars
char_account_sep :: Char
char_account_sep = '/'
char_account_tag_prefix :: Char
char_account_tag_prefix = '~'
char_ymd_sep :: Char
char_ymd_sep = '-'
char_tod_sep :: Char
char_tod_sep = ':'
char_comment_prefix :: Char
char_comment_prefix = ';'
char_tag_prefix :: Char
char_tag_prefix = '#'
char_tag_sep :: Char
char_tag_sep = ':'
char_tag_data_prefix :: Char
char_tag_data_prefix = '='
char_transaction_date_sep :: Char
char_transaction_date_sep = '='

-- * Type 'Env'
type Env src ss = Map Sym.NameTe (Sym.TermVT src ss '[])

-- * Type 'Section'
data Section
 =   Section_Terms
 |   Section_Chart
 |   Section_Transactions
 deriving (Eq, Ord, Show)

g_compta_section ::
 forall src err a g.
 Sym.ErrorInj err (Error_Compta src) =>
 G.Gram_State Section g =>
 G.Gram_Source src g =>
 Functor g =>
 Section ->
 g (S.Either (At src err) a) ->
 g (S.Either (At src (Error_Compta src)) a)
g_compta_section sec g =
	G.stateBefore $ G.source $
	(\a src sec_curr ->
		(sec,) $
		if sec_curr <= sec
		then fmap Sym.errorInj `S.left` a
		else S.Left $ At src $ Error_Compta_Section sec_curr sec
	 ) <$> g

-- * Type 'Year'
newtype Year = Year (H.Date_Year Date)
 deriving (Eq, Show)


-- * Type 'Error_Date'
data Error_Date
 =   Error_Date_Day_invalid (Integer, Int, Int)
 |   Error_Date_TimeOfDay_invalid (Int, Int, Int)
 |   Error_Date_TimeZone_unknown Text
 deriving (Eq, Show)

-- * Type 'Error_Posting'
data Error_Posting
 =   Error_Posting_Account_Ref_unknown Tag_Path
 |   Error_Posting_Account_Ref_multiple Tag_Path (Map Account ())
 |   Error_Postings_not_equilibrated Postings
 deriving (Eq, Show)

-- * Type 'Error_Transaction'
data Error_Transaction
 =   Error_Transaction_Date Error_Date
 |   Error_Transaction_Posting Error_Posting
 |   Error_Transaction_not_equilibrated
      Transaction
      [( Unit
       , H.SumByUnit (NonNull [NameAccount]) (H.Polarized Quantity)
       )]
 deriving (Eq, Show)

-- * Type 'Error_Chart'
data Error_Chart
 =   Error_Chart
 deriving (Eq, Show)

-- * Type 'Error_Compta'
data Error_Compta src
 =   Error_Compta_Transaction Error_Transaction
 |   Error_Compta_Read PathFile Exn.IOException
 |   Error_Compta_Include_loop CanonFile
 |   Error_Compta_Chart Error_Chart
 |   Error_Compta_Section Section Section
 |   Error_Compta_Term Sym.NameTe (Sym.Error_Term src)
 deriving (Eq, Show)

instance Sym.ErrorInj (Sym.NameTe, Sym.Error_Term src) (Error_Compta src) where
	errorInj (n, t) = Error_Compta_Term n t
instance Sym.ErrorInj Error_Transaction (Error_Compta src) where
	errorInj = Error_Compta_Transaction
instance Sym.ErrorInj (Error_Compta src) (Error_Compta src) where
	errorInj = id

-- * Type 'Warning_Compta'
data Warning_Compta
 =   Warning_Compta_Include_multiple CanonFile
 |   Warning_Compta_Term_redefined   Sym.NameTe
 deriving (Eq, Show)

{-
nonEmpty :: NonNull [a] -> NonEmpty a
nonEmpty n = x :| xs where (x, xs) = NonNull.splitFirst n
nonNull :: NonEmpty a -> NonNull [a]
nonNull n = NonNull.ncons x xs where x :| xs = n
-}