diff --git a/.fixme-new/log b/.fixme-new/log index 5beba185..c14b7f49 100644 Binary files a/.fixme-new/log and b/.fixme-new/log differ 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)