wip

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)

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
 

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)