Improve section checking and warn when a term is redefined.

diff --git a/lcc/Hcompta/LCC/Grammar.hs b/lcc/Hcompta/LCC/Grammar.hs
index 9f3f6d81a412c431cce443ae1fd3f3324b181e0f..9e8526ee1c5e6b3e0d47f2c1989e40629df1f3c4 100644 (file)
--- a/lcc/Hcompta/LCC/Grammar.hs
+++ b/lcc/Hcompta/LCC/Grammar.hs
@@ -3,7 +3,6 @@
 module Hcompta.LCC.Grammar where
 
 import Control.Applicative (Applicative(..), liftA2)
-import Control.Arrow (left)
 import Control.Monad (Monad(..), void)
 import Data.Bool
 import Data.Char (Char)
@@ -35,7 +34,7 @@ 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 List
+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
@@ -116,7 +115,7 @@ context_read =
         , context_read_journal       = journal :| []
         , context_read_canonfiles    = CanonFile "" :| []
         , context_read_warnings      = []
-        , context_read_section       = Section_Chart
+        , context_read_section       = Section_Terms
         }
 
 -- * Type 'Context_Sym'
@@ -268,7 +267,7 @@ class
        count :: Int -> CF g a -> CF g [a]
        count n p
                | n <= 0    = pure []
-               | otherwise = sequenceA $ List.replicate n p
+               | otherwise = sequenceA $ L.replicate n p
        count' :: Int -> Int -> CF g a -> CF g [a]
        count' m n p
         | n <= 0 || m > n = pure []
@@ -581,7 +580,7 @@ class
                                , frac
                                , S.Just fractioning
                                , grouping_of_digits int_group_sep int
-                               , grouping_of_digits frac_group_sep $ List.reverse frac
+                               , grouping_of_digits frac_group_sep $ L.reverse frac
                                ))
                 <$> ((:)
                         <$> some g_09
@@ -803,7 +802,6 @@ class
         Gram_Source src g =>
         CF g (S.Either (At src Error_Transaction) Transaction)
        g_transaction = rule "Transaction" $
-               g_put $ ((Section_Transaction,) <$>) $
                g_state_after $ (update_year <$>) $
                g_source $ g_ask_before $
                (\lr_date
@@ -892,18 +890,13 @@ class
         Gram_Source src g =>
         CF g (S.Either (At src (Error_Journal src)) Chart)
        g_chart_entry = rule "Chart" $
-               g_get_after $ g_source $
-               (\acct attrs src section ->
+               (\acct attrs ->
                        let (tags, tags2, _comments) = attrs in
-                       if case section of
-                                Section_Transaction -> False
-                                Section_Chart -> True
-                       then S.Right
-                               Chart
-                                { chart_accounts = TreeMap.singleton (H.get acct) tags
-                                , chart_tags     = Map.singleton acct () <$ tags2
-                                }
-                       else S.Left $ At src $ Error_Journal_Section section Section_Chart
+                       S.Right $
+                       Chart
+                        { chart_accounts = TreeMap.singleton (H.get acct) tags
+                        , chart_tags     = Map.singleton acct () <$ tags2
+                        }
                 )
                 <$> g_account
                 <*> g_chart_attrs
@@ -939,16 +932,17 @@ class
  , Inj_Source (Sym.KindK src) src
  , Inj_Source (Sym.AST_Type src) src
  ) => Gram_Term_Def src ss g where
-       g_term_def :: CF g ( Sym.NameTe
-                          , Either (At src (Sym.Error_Term src))
-                                   (Sym.TermVT src ss '[]) )
-       g_term_def =
+       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 $ g_get_after $
                (\n args v n2t src ->
-                       (n,) $
-                       (At src `left`) $
-                       Sym.readTerm n2t Sym.CtxTyZ $
-                       foldr (\(x, ty_x) -> BinTree0 . Sym.Token_Term_Abst src x ty_x) v args)
+                       let lr_t =
+                               Sym.readTerm n2t Sym.CtxTyZ $
+                               foldr (\(x, ty_x) -> 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_term_name
                 <*> many Sym.g_term_abst_decl
                 <*  Sym.symbol "="
@@ -989,10 +983,13 @@ class
                         -- NOTE: g_include must be the first choice
                         -- in order to have Megaparsec reporting the errors
                         -- of the included journal.
-                        , g_state_after $ mk_transaction <$> g_transaction
-                        , g_state_after $ mk_chart <$> g_chart_entry
-                        , g_state_after $ g_state_after $ g_input $ mk_term <$> g_term_def
-                        , [] <$ try (g_spaces <* g_eol)
+                        , g_state_after $ mk_transaction
+                                <$> g_journal_section Section_Transactions g_transaction
+                        , g_state_after $ mk_chart
+                                <$> g_journal_section Section_Chart g_chart_entry
+                        , g_state_before $ g_state_before $ g_input $ g_source $ mk_term
+                                <$> g_journal_section Section_Terms g_term_def
+                        , ([], []) <$ try (g_spaces <* g_eol)
                         ])
                where
                init_journal
@@ -1010,16 +1007,18 @@ class
                                ctx
                                 { context_read_journals   = Journals $ Map.insert cf jnl js
                                 , context_read_journal    = jnl <| jnls
-                                , context_read_canonfiles = cf <| cfs
+                                , context_read_canonfiles = cf  <| cfs
                                 }
-               mk_journal err errs
+               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_canonfiles = cf  :| cfs
+                        , context_read_warnings   = warnings
                         }::Context_Read src j) =
-                       case concat $ S.either (pure . pure) (const []) err <> errs of
+                       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, jnl'))
@@ -1027,27 +1026,35 @@ class
                                 { 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 jnl@Journal{journal_content=j} =
                        case lr_txn of
-                        S.Left err  -> (jnl, [Error_Journal_Transaction <$> err])
-                        S.Right txn -> (jnl{ journal_content = txn `consTxn` j }, [])
+                        S.Left err  -> (jnl, ([err], []))
+                        S.Right txn -> (jnl{ journal_content = txn `consTxn` j }, ([], []))
                mk_include lr_inc (jnl::Journal j) =
                        case lr_inc of
-                        S.Left errs -> (jnl, errs)
-                        S.Right (cf, _inc) -> (jnl{ journal_includes = journal_includes jnl <> [cf] }, [])
+                        S.Left errs -> (jnl, (errs, []))
+                        S.Right (cf, _inc) -> (jnl{ journal_includes = journal_includes jnl <> [cf] }, ([], []))
                mk_chart lr_ch chart =
                        case lr_ch of
-                        S.Left err -> (chart, [err])
-                        S.Right ch -> (chart <> ch, [])
-               mk_term (n, lr_te) txt mods =
+                        S.Left err -> (chart, ([err], []))
+                        S.Right ch -> (chart <> ch, ([], []))
+               mk_term lr_te src body mods =
                        case lr_te of
-                        Left err -> (mods, \(terms::Terms) -> (terms, [Error_Journal_Term <$> err]))
-                        Right te -> (ins_term te mods, \terms -> (Map.insert ([] `Sym.Mod` n) txt terms, []))
+                        S.Left err      -> (mods, (, ([err], [])))
+                        S.Right (n, te) -> (ins_term n te mods, \ts -> (ins_body n body ts, ([], warn_redef n ts)))
                        where
-                       ins_term :: Sym.TermVT src ss '[] -> Sym.Modules src ss -> Sym.Modules src ss
-                       ins_term t = Sym.insertTermVT ([] `Sym.Mod` t) n (Sym.Fixity2 Sym.infixN5)
+                       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 t = Map.insert ([] `Sym.Mod` n) t
+                       warn_redef :: Sym.NameTe -> Terms -> [At src Warning_Journal]
+                       warn_redef n ts =
+                               case Map.lookup ([] `Sym.Mod` n) ts of
+                                Just{} -> [At src $ Warning_Journal_Term_redefined n]
+                                Nothing -> []
        g_include
         :: (Transaction -> j -> j)
         -> CF g (S.Either [At src (Error_Journal src)]
@@ -1079,8 +1086,9 @@ class
                                        then (ctx, S.Left $ Error_Journal_Include_loop cf)
                                        else
                                                (,S.Right fp) $
-                                               if isJust $ (`List.find` warns) $ \case
+                                               if isJust $ (`L.find` warns) $ \case
                                                 At{unAt=Warning_Journal_Include_multiple cf'} -> cf' `elem` cf<|cfs
+                                                _ -> False
                                                then ctx
                                                else ctx
                                                 { context_read_warnings =
@@ -1132,9 +1140,28 @@ type Env src ss = Map Sym.NameTe (Sym.TermVT src ss '[])
 
 -- * Type 'Section'
 data Section
- =   Section_Chart
- |   Section_Transaction
- deriving (Eq, Show)
+ =   Section_Terms
+ |   Section_Chart
+ |   Section_Transactions
+ deriving (Eq, Ord, Show)
+
+g_journal_section ::
+ forall src err a g.
+ Sym.Inj_Error err (Error_Journal src) =>
+ Gram_State Section g =>
+ Gram_Source src g =>
+ Functor g =>
+ Section ->
+ g (S.Either (At src err) a) ->
+ g (S.Either (At src (Error_Journal src)) a)
+g_journal_section sec g =
+       g_state_before $ g_source $
+       (\a src sec_curr ->
+               (sec,) $
+               if sec_curr <= sec
+               then fmap Sym.inj_Error `S.left` a
+               else S.Left $ At src $ Error_Journal_Section sec_curr sec
+        ) <$> g
 
 -- * Type 'Year'
 newtype Year = Year (H.Date_Year Date)
@@ -1177,12 +1204,20 @@ data Error_Journal src
  |   Error_Journal_Include_loop CanonFile
  |   Error_Journal_Chart Error_Chart
  |   Error_Journal_Section Section Section
- |   Error_Journal_Term (Sym.Error_Term src)
+ |   Error_Journal_Term Sym.NameTe (Sym.Error_Term src)
  deriving (Eq, Show)
 
+instance Sym.Inj_Error (Sym.NameTe, Sym.Error_Term src) (Error_Journal src) where
+       inj_Error (n, t) = Error_Journal_Term n t
+instance Sym.Inj_Error Error_Transaction (Error_Journal src) where
+       inj_Error = Error_Journal_Transaction
+instance Sym.Inj_Error (Error_Journal src) (Error_Journal src) where
+       inj_Error = id
+
 -- * Type 'Warning_Journal'
 data Warning_Journal
  =   Warning_Journal_Include_multiple CanonFile
+ |   Warning_Journal_Term_redefined   Sym.NameTe
  deriving (Eq, Show)
 
 {-

diff --git a/lcc/Hcompta/LCC/Lib/Strict.hs b/lcc/Hcompta/LCC/Lib/Strict.hs
index d479c4a7b63103b862534e1e945f7bc97fce8870..cd6750b6ca903280ead9e45fbded42dd17004444 100644 (file)
--- a/lcc/Hcompta/LCC/Lib/Strict.hs
+++ b/lcc/Hcompta/LCC/Lib/Strict.hs
@@ -5,6 +5,7 @@ module Hcompta.LCC.Lib.Strict where
 
 -- import Data.Bool
 -- import qualified Control.Monad.Classes as MC
+import qualified Data.Either as Lazy
 import Control.Applicative (Applicative(..))
 import Control.Monad (Monad(..))
 import Control.Monad.IO.Class (MonadIO(..))
@@ -17,8 +18,14 @@ import Data.Strict
 import qualified Control.Monad.Trans.Reader as R
 import qualified Control.Monad.Trans.State.Strict as SS
 
--- * Type 'Maybe'
+-- * Class 'StrictOf'
+class StrictOf a b where
+       strictOf :: a -> b
+instance StrictOf (Lazy.Either l r) (Either l r) where
+       strictOf (Lazy.Left  l) = Left l
+       strictOf (Lazy.Right r) = Right r
 
+-- * Type 'Maybe'
 instance Applicative Maybe where
        pure = Just
        Nothing <*> _       = Nothing

diff --git a/lcc/Hcompta/LCC/Load.hs b/lcc/Hcompta/LCC/Load.hs
index 8c153dd556c055725e488cba7f36e908cef87ebf..e73894905b0a37bdc3031e3df444060b7dbf4d9b 100644 (file)
--- a/lcc/Hcompta/LCC/Load.hs
+++ b/lcc/Hcompta/LCC/Load.hs
@@ -10,10 +10,11 @@ import Data.Either (Either(..))
 -- import Data.Eq (Eq)
 import Data.Function (($))
 import Data.Functor ((<$>))
+import Data.List.NonEmpty (NonEmpty)
 -- import Data.Maybe (Maybe(..))
 -- import Data.Semigroup ((<>))
 -- import Data.Text (Text)
-import System.IO (IO, stdout, stderr)
+import System.IO (IO, stdout, stderr, print)
 import Text.Show (Show(..))
 import qualified Data.Strict as S
 -- import qualified Control.Monad.Trans.State.Strict as SS
@@ -23,14 +24,14 @@ import qualified System.Environment as Env
 -- import qualified Text.Megaparsec as P
 
 import qualified Language.Symantic.Document as Doc
--- import Language.Symantic.Grammar
+import qualified Language.Symantic as Sym
 -- import Language.Symantic as Sym
 -- import qualified Language.Symantic.Lib as Sym
 
 -- import qualified Hcompta.LCC as LCC
 import qualified Hcompta.LCC.Sym as LCC.Sym
 import Hcompta.LCC.Megaparsec (showParseError)
--- import Hcompta.LCC.Grammar
+import Hcompta.LCC.Posting (SourcePos)
 import Hcompta.LCC.Read
 import Hcompta.LCC.Document
 
@@ -41,8 +42,8 @@ import Hcompta.LCC.Document
 -- import qualified Control.Monad.Classes.Run as MC
 import Prelude (error)
 
-type SS = LCC.Sym.SS
-type SRC = ()
+type SS  = LCC.Sym.SS
+type SRC = Sym.SrcTe (NonEmpty SourcePos) SS
 
 main :: IO ()
 main = do
@@ -53,7 +54,8 @@ main = do
                        showParseError err >>=
                        (`Doc.ansiIO` stderr)
                 Left (Error_Read_Semantic err) -> error $ show err
-                Right r -> do
+                Right (r, warns) -> do
+                       print warns
                        -- print r
                        (`Doc.ansiIO` stdout) $
                                d_compta context_write r

diff --git a/lcc/Hcompta/LCC/Megaparsec.hs b/lcc/Hcompta/LCC/Megaparsec.hs
index 55a29ec3c9dacc5911e0801c787dd5a2b89c51a6..6a9242b2b8d0153688ac96c2084fdcaa1ad41323 100644 (file)
--- a/lcc/Hcompta/LCC/Megaparsec.hs
+++ b/lcc/Hcompta/LCC/Megaparsec.hs
@@ -73,7 +73,7 @@ instance ParsecC e s => IsString (P.ParsecT e s m [Char]) where
 -- Readers
 --
 
--- NonEmpty P.SourcePos
+-- NonEmpty SourcePos
 instance ParsecC e s => Sym.Gram_Reader (NonEmpty SourcePos) (P.ParsecT e s m) where
        g_ask_before g = do
                s <- (sourcePos <$>) . P.statePos <$> P.getParserState
@@ -84,7 +84,7 @@ instance ParsecC e s => Sym.Gram_Reader (NonEmpty SourcePos) (P.ParsecT e s m) w
 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader (NonEmpty SourcePos)) = 'True
 instance ParsecC e s => MC.MonadReaderN 'MC.Zero (NonEmpty SourcePos) (P.ParsecT e s m) where
        askN _n = (sourcePos <$>) . P.statePos <$> P.getParserState
--- P.SourcePos
+-- SourcePos
 instance ParsecC e s => Sym.Gram_Reader SourcePos (P.ParsecT e s m) where
        g_ask_before g = do
                s <- sourcePos <$> P.getPosition

diff --git a/lcc/Hcompta/LCC/Read.hs b/lcc/Hcompta/LCC/Read.hs
index d7e7b9f314a122a4158e9683a358753a486e81f7..ad52a7068b30f52cbdf0f3488fe8b6b9d9e6a057 100644 (file)
--- a/lcc/Hcompta/LCC/Read.hs
+++ b/lcc/Hcompta/LCC/Read.hs
@@ -102,15 +102,17 @@ readCompta ::
  Sym.Inj_Modules src ss =>
  FilePath ->
  -- (Transaction -> j -> j) ->
- IO (Either (Error_Read src) (Compta src ss))
+ IO (Either (Error_Read src) (Compta src ss, [At src Warning_Journal]))
 readCompta path = do
-       ((r, ctxRead), ctxSym) <- readFile path $ read $ g_journal @ss (\t -> Map.insertWith (<>) (transaction_date t) [t])
+       ((r, ctxRead), ctxSym) <-
+               readFile path $ read $
+               g_journal @ss (\t -> Map.insertWith (<>) (transaction_date t) [t])
        return $ case r of
         Left err -> Left $ Error_Read_Syntax err
         Right r' ->
                case r' of
                 S.Left err -> Left $ Error_Read_Semantic err
-                S.Right _r'' -> Right $ Compta
+                S.Right _r'' -> Right $ (,context_read_warnings ctxRead) Compta
                         { compta_journals      = context_read_journals      ctxRead
                         , compta_chart         = context_read_chart         ctxRead
                         , compta_style_amounts = context_read_style_amounts ctxRead