From dc833177c8eecc3f3e3b192170328ada91a7f3b6 Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Fri, 7 Jun 2024 07:57:37 +0300
Subject: [PATCH] wip

---
 .fixme-new/log               | Bin 3892 -> 4170 bytes
 fixme-new/lib/Fixme/Run.hs   |  21 +++++++++++++++++---
 fixme-new/lib/Fixme/State.hs |  36 ++++++++++++++++++++++++-----------
 fixme-new/lib/Fixme/Types.hs |  17 ++++++++++++++++-
 4 files changed, 59 insertions(+), 15 deletions(-)

diff --git a/.fixme-new/log b/.fixme-new/log
index 5beba1858aee7ea861c5b761340a7efe0e996529..c14b7f49faa4f6225938d656288f1a0e161883cc 100644
GIT binary patch
delta 288
zcmdlYcS>P{34c8U7zk*!GD@W-O=4+cXkv&^nEd2G*Op{1efI|(H|JS4pMAN%T69a$
zbgmm&tDhOKe1ETrA)`FMC_61Dzr2Ydr6jeu1fqRCM7zn--ya3rPg^IRW^dSQW*You
zg|zcAx&J3Jb|jnKJ1PDQNqaq1KZ98t&}K>g>LvyWdxkF&>b}Go1=DAPrjL*h>Npq}
WK|YsYVBj}_gaQ99Ak742ivR$_jB9oP

delta 7
OcmX@5utjcz2|oY~&;qak

diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs
index 40585e2c..540400f0 100644
--- a/fixme-new/lib/Fixme/Run.hs
+++ b/fixme-new/lib/Fixme/Run.hs
@@ -103,10 +103,14 @@ defaultTemplate = HM.fromList [ ("default", Simple (SimpleTemplate short)) ]
 
 runFixmeCLI :: FixmePerks m => FixmeM m a -> m a
 runFixmeCLI m = do
-  db <- newDBPipeEnv dbPipeOptsDef =<< localDBPath
+  dbPath <- localDBPath
   git <- findGitDir
-  env <- FixmeEnv db
-            <$>  newTVarIO git
+  env <- FixmeEnv
+            <$>  newMVar ()
+            <*>  newTVarIO mempty
+            <*>  newTVarIO dbPath
+            <*>  newTVarIO Nothing
+            <*>  newTVarIO git
             <*>  newTVarIO mempty
             <*>  newTVarIO mempty
             <*>  newTVarIO mempty
@@ -325,6 +329,9 @@ printEnv = do
   for_ g $ \git -> do
     liftIO $ print $ "fixme-git-dir" <+> dquotes (pretty git)
 
+  dbPath <- asks fixmeEnvDbPath >>= readTVarIO
+  liftIO $ print $ "fixme-state-path" <+> dquotes (pretty dbPath)
+
   (before,after) <- asks fixmeEnvCatContext >>= readTVarIO
 
   liftIO $ print $ "fixme-def-context" <+> pretty before <+> pretty after
@@ -426,6 +433,14 @@ runForms ss = for_  ss $ \s -> do
       ta <- asks fixmeEnvGitDir
       atomically $ writeTVar ta (Just g)
 
+    ListVal [SymbolVal "fixme-state-path", StringLike g] -> do
+      p <- asks fixmeEnvDbPath
+      db <- asks fixmeEnvDb
+      atomically do
+        writeTVar db Nothing
+        writeTVar p g
+      evolve
+
     ListVal [SymbolVal "fixme-def-context", LitIntVal a, LitIntVal b] -> do
       t <- asks fixmeEnvCatContext
       atomically $ writeTVar t (fromIntegral a, fromIntegral b)
diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs
index 7f0a089b..dda443d8 100644
--- a/fixme-new/lib/Fixme/State.hs
+++ b/fixme-new/lib/Fixme/State.hs
@@ -53,6 +53,14 @@ import Data.Fixed
 import Data.Word (Word64)
 import System.TimeIt
 
+-- TODO: runPipe-omitted
+--   runPipe нигде не запускается, значит, все изменения
+--   будут закоммичены в БД только по явному вызову
+--   commitAll или transactional
+--   это может объясняеть некоторые артефакты.
+--   Но это и удобно: кажется, что можно менять БД
+--   на лету бесплатно
+
 
 pattern Operand :: forall {c} . Text -> Syntax c
 pattern Operand what <- (operand -> Just what)
@@ -83,21 +91,27 @@ instance FromField HashRef where
   fromField = fmap (fromString @HashRef) . fromField @String
 
 evolve :: FixmePerks m => FixmeM  m ()
-evolve = do
-  dbpath <- localDBPath
-  debug $ "evolve" <+> pretty dbpath
-  mkdir (takeDirectory dbpath)
-
-  db <- newDBPipeEnv dbPipeOptsDef dbpath
-
-  withDB db do
+evolve = withState do
     createTables
 
 withState :: forall m a . (FixmePerks m, MonadReader FixmeEnv m) => DBPipeM m a ->  m a
 withState what = do
-  db <- asks fixmeEnvDb
-  withDB db what
+  lock <- asks fixmeLock
+  db <- withMVar lock $ \_ -> do
+          t <- asks fixmeEnvDb
+          mdb <- readTVarIO t
+          case mdb of
+            Just d  -> pure (Right d)
+            Nothing -> do
+              path <- asks fixmeEnvDbPath >>= readTVarIO
+              newDb <- try @_ @IOException (newDBPipeEnv dbPipeOptsDef path)
+              case newDb of
+                Left e   -> pure (Left e)
+                Right db -> do
+                  atomically $ writeTVar t (Just db)
+                  pure $ Right db
 
+  either throwIO (`withDB` what) db
 
 createTables :: FixmePerks m => DBPipeM m ()
 createTables = do
@@ -513,7 +527,7 @@ select  cast(json_patch(j.json, coalesce(s.json,{emptyObect})) as blob) as blob
 from
   fixmejson j join fixmeactual f on f.fixme = j.fixme
               join fixme f0 on f0.id = f.fixme
-              left join s1 s on s.hash = f0.id
+              left join s1 s on s.hash = j.fixme
 
 where
 
diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs
index 2d828693..6c0dd2ca 100644
--- a/fixme-new/lib/Fixme/Types.hs
+++ b/fixme-new/lib/Fixme/Types.hs
@@ -239,9 +239,24 @@ data RenderError = RenderError String
 class FixmeRenderTemplate a b where
   render :: a -> Either RenderError b
 
+data FixmeOpts =
+  FixmeOpts
+  { fixmeOptNoEvolve :: Bool
+  }
+  deriving stock (Eq,Ord,Show,Data,Generic)
+
+instance Monoid FixmeOpts where
+  mempty = FixmeOpts False
+
+instance Semigroup FixmeOpts where
+  (<>) _ b = FixmeOpts (fixmeOptNoEvolve b)
+
 data FixmeEnv =
   FixmeEnv
-  { fixmeEnvDb             :: DBPipeEnv
+  { fixmeLock              :: MVar ()
+  , fixmeEnvOpts           :: TVar FixmeOpts
+  , fixmeEnvDbPath         :: TVar FilePath
+  , fixmeEnvDb             :: TVar (Maybe DBPipeEnv)
   , fixmeEnvGitDir         :: TVar (Maybe FilePath)
   , fixmeEnvFileMask       :: TVar [FilePattern]
   , fixmeEnvTags           :: TVar (HashSet FixmeTag)