diff --git a/.fixme-new/log b/.fixme-new/log index 04eaf073..e69de29b 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 7556b143..6813e1d1 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -520,50 +520,49 @@ run what = do warn $ red "GENERATE FORMS? FROM STAGE" - what <- selectStage @C + what <- selectStage for_ what $ \w -> do warn $ pretty w warn $ red "ADD RECORDS FROM STAGE TO BINARY LOG" - sto <- compactStorageOpen @HbSync mempty fn + -- sto <- compactStorageOpen @HbSync mempty fn - wtf <- S.toList_ $ runMaybeT do - rv <- MaybeT $ getRef sto logRootKey - walkMerkle rv (getBlock sto) $ \case - Left{} -> pure () - Right (xs :: [Text]) -> do - let what = fmap parseTop xs & rights & mconcat - lift $ mapM_ S.yield (sanitizeLog what) + -- wtf <- S.toList_ $ runMaybeT do + -- rv <- MaybeT $ getRef sto logRootKey + -- walkMerkle rv (getBlock sto) $ \case + -- Left{} -> pure () + -- Right (xs :: [Text]) -> do + -- let what = fmap parseTop xs & rights & mconcat + -- lift $ mapM_ S.yield (sanitizeLog what) - let theLog = Set.fromList (wtf <> what) & Set.toList - -- FIXME: mtree-params-hardcode + -- let theLog = Set.fromList (wtf <> what) & Set.toList + -- -- FIXME: mtree-params-hardcode - let new = theLog & fmap ( fromString @Text . show . pretty ) - let pt = toPTree (MaxSize 1024) (MaxNum 256) new + -- let new = theLog & fmap ( fromString @Text . show . pretty ) + -- let pt = toPTree (MaxSize 1024) (MaxNum 256) new - -- FIXME: fuck-the-fucking-scientific - -- сраный Scientiс не реализует Generic - -- и не открывает конструкторы, нельзя - -- сделать инстанс Serialise. - -- надо выпилить его к херам. а пока вот так - h <- makeMerkle 0 pt $ \(_,_,bss) -> do - void $ putBlock sto bss + -- -- FIXME: fuck-the-fucking-scientific + -- -- сраный Scientiс не реализует Generic + -- -- и не открывает конструкторы, нельзя + -- -- сделать инстанс Serialise. + -- -- надо выпилить его к херам. а пока вот так + -- h <- makeMerkle 0 pt $ \(_,_,bss) -> do + -- void $ putBlock sto bss - updateRef sto logRootKey h + -- updateRef sto logRootKey h - compactStorageClose sto + -- compactStorageClose sto - liftIO $ print $ vcat (fmap pretty new) + -- liftIO $ print $ vcat (fmap pretty new) warn $ red "DELETE STAGE" warn $ red "SCAN BINARY LOG?" warn $ red "RUN NEW FORMS" - liftIO $ withFixmeEnv env (runForms theLog) - - cleanStage + -- liftIO $ withFixmeEnv env (runForms theLog) + -- cleanStage ListVal [SymbolVal "no-debug"] -> do setLoggingOff @DEBUG @@ -581,19 +580,20 @@ run what = do cleanStage ListVal [SymbolVal "builtin:show-stage"] -> do - stage <- selectStage @C + stage <- selectStage liftIO $ print $ vcat (fmap pretty stage) ListVal [SymbolVal "builtin:show-log", StringLike fn] -> do sto <- compactStorageOpen @HbSync readonly fn - void $ runMaybeT do - rv <- MaybeT $ getRef sto logRootKey + -- FIXME: re-implement + -- void $ runMaybeT do + -- rv <- MaybeT $ getRef sto logRootKey - walkMerkle rv (getBlock sto) $ \case - Left{} -> error "malformed log" - Right (xs :: [Text]) -> do - liftIO $ mapM_ (print . pretty) xs + -- walkMerkle rv (getBlock sto) $ \case + -- Left{} -> error "malformed log" + -- Right (xs :: [Text]) -> do + -- liftIO $ mapM_ (print . pretty) xs compactStorageClose sto diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index be0f0edd..3ee54fe9 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -570,22 +570,21 @@ insertFixmeDelStaged hash = withState do |] (hash,ts) -type StageModRow = (Text,Integer,Text,Text) +type StageModRow = (HashRef,Word64,Text,Text) -selectStageModified :: (IsContext c,FixmePerks m,MonadReader FixmeEnv m) => m [Syntax c] +selectStageModified :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction] selectStageModified = withState do what <- select_ @_ @StageModRow [qc|select hash,ts,attr,value from fixmestagemod|] for what $ \(h,t,k,v) -> do - pure $ mklist [mksym "modified", mkint t, mkstr h, mkstr k, mkstr v] + pure $ Modified t h (FixmeAttrName k) (FixmeAttrVal v) - -selectStageDeleted :: (IsContext c,FixmePerks m,MonadReader FixmeEnv m) => m [Syntax c] +selectStageDeleted :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction] selectStageDeleted = withState do - what <- select_ @_ @(Text,Word64) [qc|select hash,ts from fixmestagedel|] + what <- select_ @_ @(HashRef,Word64) [qc|select hash,ts from fixmestagedel|] for what $ \(h,t) -> do - pure $ mklist [mksym "deleted", mkstr h] + pure $ Deleted t h -selectStage :: (IsContext c,FixmePerks m,MonadReader FixmeEnv m) => m [Syntax c] +selectStage :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction] selectStage = do a <- selectStageModified b <- selectStageDeleted diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index fbc29b2a..9e127570 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -66,6 +66,12 @@ class IsContext c => MkStr c a where instance IsContext c => MkStr c FixmeAttrVal where mkstr (s :: FixmeAttrVal) = Literal (noContext @c) (LitStr (coerce s)) +instance IsContext c => MkStr c FixmeAttrName where + mkstr (s :: FixmeAttrName) = Literal (noContext @c) (LitStr (coerce s)) + +instance IsContext c => MkStr c HashRef where + mkstr s = Literal (noContext @c) (LitStr (fromString $ show $ pretty s)) + instance IsContext c => MkStr c Text where mkstr = Literal noContext . LitStr @@ -182,8 +188,10 @@ data CompactAction = instance Pretty CompactAction where pretty = \case - Deleted s r -> pretty $ mklist @C [ mksym "deleted" ] + Deleted s r -> pretty $ mklist @C [ mksym "deleted", mkint s, mkstr r ] + Modified s r k v -> pretty $ mklist @C [ mksym "modified", mkint s, mkstr r, mkstr k, mkstr v ] +instance Serialise CompactAction data FixmeTemplate = Simple SimpleTemplate