From 570f93543db1bf3684a5684476f0d2df51aaa02c Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Mon, 3 Jun 2024 14:00:39 +0300 Subject: [PATCH] wip --- .fixme-new/log | Bin 1462 -> 0 bytes fixme-new/lib/Fixme/Run.hs | 66 +++++++++++++++++------------------ fixme-new/lib/Fixme/State.hs | 15 ++++---- fixme-new/lib/Fixme/Types.hs | 10 +++++- 4 files changed, 49 insertions(+), 42 deletions(-) diff --git a/.fixme-new/log b/.fixme-new/log index 04eaf073e9c2b6158a29faaa09258ad9b264c757..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 100644 GIT binary patch literal 0 HcmV?d00001 literal 1462 zcmZQz0E0a77jhbAgCVcyqcglTth~(P|vJ5jqx~F<<;da_1+|1C#z|g>; z*9N2|beb607`{X(h7r;QQO^O?q5@JMq`K4p$W!qirt=^7Oc9>9a&3EuC9nAk!ET@I z>wPtH4}a8gFfc+K1t*PwEG9S)%wW6;axtT!TVH17yz{z01KecA68EiQJXoVSwL0FH z>Gy`E=c9HuG0v~B&`3$mNi9iDQBZOzNe;{`vdr~JH4ie)tcY}v2uUiAa1Tfga}To! zDRlJBEh>vlcds-ocXv|KtccXe%}>cp%S=t-QZO_(G&eCYFfuXcQcyAq$WF~I&u}R& z_9!=VN-+yg_eyegHaD(xH+Oa`OA1fP3k@jpF3U5GtO!v8sxQwk%1+D4F9)+T3zRhf zGw6c@@g6W#W`aYJkWZi*c99c|n;=2QSdJ8olOSTuwV+^Z)Sq4we8@sDhe3GGfzpHe z3_Y!4k0l}v65>=B?hPtMl#}v@h3DsBoT4M zcoQPVIt>&@f4jscPha@`;^&mFp9F4h?Tc)Ek)^jUcGtQHzO>sbGZ`q0Bcx2?Ze(GU zTi{b*XzW~Om{^z@4NzrFmW(u bfD;CxsDUO7=A~pL4CcAeL|}+W7|gW*$z9i+ 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