{-# 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 -}