From 09ebc4fc0d07bed17585b7c2e6a1942e6d4cf539 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sun, 12 May 2024 09:04:51 +0300 Subject: [PATCH] wip --- fixme-new/fixme.cabal | 1 + fixme-new/lib/Fixme/Config.hs | 26 +++++++ fixme-new/lib/Fixme/Prelude.hs | 5 +- fixme-new/lib/Fixme/Run.hs | 122 +++++++++++++++++++------------- fixme-new/lib/Fixme/Scan.hs | 6 +- fixme-new/lib/Fixme/State.hs | 123 ++++++++++++++++++++++++++++++++- fixme-new/lib/Fixme/Types.hs | 29 ++------ 7 files changed, 234 insertions(+), 78 deletions(-) create mode 100644 fixme-new/lib/Fixme/Config.hs diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index 2926c386..df576fd3 100644 --- a/fixme-new/fixme.cabal +++ b/fixme-new/fixme.cabal @@ -101,6 +101,7 @@ library exposed-modules: Fixme + Fixme.Config Fixme.Run Fixme.Types Fixme.Prelude diff --git a/fixme-new/lib/Fixme/Config.hs b/fixme-new/lib/Fixme/Config.hs new file mode 100644 index 00000000..4b1b8ae5 --- /dev/null +++ b/fixme-new/lib/Fixme/Config.hs @@ -0,0 +1,26 @@ +module Fixme.Config where + +import Fixme.Prelude +import Fixme.Types + +import HBS2.System.Dir +import System.Environment + +binName :: FixmePerks m => m FilePath +binName = liftIO getProgName + +localConfigDir :: FixmePerks m => m FilePath +localConfigDir = do + p <- pwd + b <- binName + pure (p ("." <> b)) + +localConfig:: FixmePerks m => m FilePath +localConfig = localConfigDir <&> ( "config") + +localDBName :: FilePath +localDBName = "state.db" + +localDBPath :: FixmePerks m => m FilePath +localDBPath = localConfigDir <&> ( localDBName) + diff --git a/fixme-new/lib/Fixme/Prelude.hs b/fixme-new/lib/Fixme/Prelude.hs index 78e12eaa..01d266ee 100644 --- a/fixme-new/lib/Fixme/Prelude.hs +++ b/fixme-new/lib/Fixme/Prelude.hs @@ -2,13 +2,16 @@ module Fixme.Prelude ( module All , GitHash(..) , Serialise(..) + , serialise, deserialiseOrFail, deserialise ) where import HBS2.Prelude.Plated as All +import HBS2.Hash as All +import HBS2.Data.Types.Refs as All import HBS2.Misc.PrettyStuff as All import HBS2.System.Logger.Simple.ANSI as All import HBS2.Git.Local (GitHash(..)) -import Codec.Serialise (Serialise(..)) +import Codec.Serialise (Serialise(..),serialise,deserialise,deserialiseOrFail) import Data.Functor as All import Data.Function as All import UnliftIO as All diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 39120285..486545a2 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -6,6 +6,8 @@ module Fixme.Run where import Prelude hiding (init) import Fixme.Prelude hiding (indent) import Fixme.Types +import Fixme.Config +import Fixme.State import Fixme.Scan.Git as Git import Fixme.Scan as Scan @@ -74,6 +76,7 @@ pattern StringLikeList e <- (stringLikeList -> e) data ScanGitArgs = PrintBlobs | PrintFixme + | ScanRunDry deriving stock (Eq,Ord,Show,Data,Generic) pattern ScanGitArgs :: forall {c} . ScanGitArgs -> Syntax c @@ -83,6 +86,7 @@ scanGitArg :: Syntax c -> Maybe ScanGitArgs scanGitArg = \case SymbolVal "print-blobs" -> Just PrintBlobs SymbolVal "print-fixme" -> Just PrintFixme + SymbolVal "dry" -> Just ScanRunDry _ -> Nothing scanGitArgs :: [Syntax c] -> [ScanGitArgs] @@ -105,17 +109,39 @@ fixmePrefix = \case SymbolVal s -> Just (FixmeTag (coerce s)) _ -> Nothing -binName :: FixmePerks m => m FilePath -binName = liftIO getProgName -localConfigDir :: FixmePerks m => m FilePath -localConfigDir = do - p <- pwd - b <- binName - pure (p ("." <> b)) +runFixmeCLI :: FixmePerks m => FixmeM m a -> m a +runFixmeCLI m = do + db <- newDBPipeEnv dbPipeOptsDef =<< localDBPath + env <- FixmeEnv Nothing db + <$> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO defCommentMap + <*> newTVarIO Nothing + + runReaderT ( setupLogger >> fromFixmeM (evolve >> m) ) env + `finally` flushLoggers + where + setupLogger = do + setLogging @ERROR $ toStderr . logPrefix "[error] " + setLogging @WARN $ toStderr . logPrefix "[warn] " + setLogging @NOTICE $ toStdout . logPrefix "" + pure () + + flushLoggers = do + silence + + +silence :: FixmePerks m => m () +silence = do + setLoggingOff @DEBUG + setLoggingOff @ERROR + setLoggingOff @WARN + setLoggingOff @NOTICE -localConfig:: FixmePerks m => m FilePath -localConfig = localConfigDir <&> ( "config") readConfig :: FixmePerks m => FixmeM m [Syntax C] @@ -140,7 +166,7 @@ init = do unless here do liftIO $ writeFile gitignore $ show $ - vcat [ "./state.db" + vcat [ pretty ("." localDBName) ] notice $ yellow "run" <> line <> vcat [ @@ -211,11 +237,16 @@ filterBlobs xs = do let r = [(h,f) | (_,(f,h),_) <- matchMany pat src] & HM.fromList & HM.toList pure $ [ (b,a) | (a,b) <- r ] -scanGitLocal :: FixmePerks m => [ScanGitArgs] -> Maybe FilePath -> FixmeM m () +scanGitLocal :: FixmePerks m + => [ScanGitArgs] + -> Maybe FilePath + -> FixmeM m () scanGitLocal args p = do env <- ask + dbpath <- localDBPath + flip runContT pure do (dbFn, _) <- ContT $ withSystemTempFile "fixme-db" . curry @@ -246,6 +277,7 @@ scanGitLocal args p = do ) |] + update_ [qc|ATTACH DATABASE '{dbpath}' as fixme|] co <- lift listCommits @@ -304,6 +336,7 @@ scanGitLocal args p = do poor <- lift (Scan.scanBlob (Just fp) blob) + rich <- withDB tempDb do let q = [qc| @@ -338,7 +371,12 @@ scanGitLocal args p = do ]) for poor $ \f -> do - pure $ over (field @"fixmeAttr") (<> what) f + let ts = HM.lookup "commit-time" what + <&> Text.unpack . coerce + >>= readMay + <&> FixmeTimestamp + + pure $ set (field @"fixmeTs") ts $ over (field @"fixmeAttr") (<> what) f let fixmies = rich @@ -346,30 +384,18 @@ scanGitLocal args p = do for_ fixmies $ \fixme -> do liftIO $ print $ pretty fixme + when ( ScanRunDry `elem` args ) $ fucked () + + debug $ "actually-import-fixmies" <+> pretty h + + liftIO $ withFixmeEnv env $ withState $ transactional do + for_ fixmies $ \fixme@Fixme{..} -> do + debug $ "fixme-ts:" <+> pretty fixmeTs + insertFixme fixme + _ -> fucked () - -- when ( PrintFixme `elem` args ) do - - -- for_ blobs $ \(fp,h) -> do - -- liftIO $ IO.hPrint ssin (pretty h) >> IO.hFlush ssin - -- prefix <- liftIO (BS.hGetLine ssout) <&> BS.words - - -- case prefix of - -- [_, "blob", ssize] -> do - -- let mslen = readMay @Int (BS.unpack ssize) - -- len <- ContT $ maybe1 mslen (pure ()) - -- blob <- liftIO $ LBS8.hGet ssout len - -- void $ liftIO $ BS.hGetLine ssout - - -- fixmies <- lift (Scan.scanBlob (Just fp) blob) - - -- for_ fixmies $ \fixme -> do - -- liftIO $ print $ pretty fixme - - -- _ -> fucked () - - -- debug $ red "NOW WHAT?" startGitCatFile :: (FixmePerks m, MonadReader FixmeEnv m) => m (Process Handle Handle ()) @@ -380,21 +406,6 @@ startGitCatFile = do let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ shell cmd startProcess config -extractFixmeFromGitBlob :: FixmePerks m => FilePath -> GitHash -> FixmeM m [Fixme] -extractFixmeFromGitBlob fp gh = do - pure mempty - -exractFixme :: FixmePerks m => ByteString -> m [Fixme] -exractFixme bs = do - - let ls = LBS8.lines bs - - pure mempty - - -readUtf8 :: ByteString -> Text -readUtf8 bs = LBS8.toStrict bs & Text.decodeUtf8 - readFixmeStdin :: FixmePerks m => FixmeM m () readFixmeStdin = do @@ -450,6 +461,7 @@ splitForms :: [String] -> [[String]] splitForms s0 = runIdentity $ S.toList_ (go mempty s0) where go acc ( "then" : rest ) = emit acc >> go mempty rest + go acc ( "and" : rest ) = emit acc >> go mempty rest go acc ( x : rest ) = go ( x : acc ) rest go acc [] = emit acc @@ -515,6 +527,20 @@ run what = do ListVal [SymbolVal "no-debug"] -> do setLoggingOff @DEBUG + ListVal [SymbolVal "silence"] -> do + silence + + ListVal [SymbolVal "builtin:evolve"] -> do + evolve + + ListVal [SymbolVal "trace"] -> do + setLogging @TRACE (logPrefix "[trace] " . toStderr) + trace "trace on" + + ListVal [SymbolVal "no-trace"] -> do + trace "trace off" + setLoggingOff @TRACE + ListVal [SymbolVal "debug"] -> do setLogging @DEBUG $ toStderr . logPrefix "[debug] " diff --git a/fixme-new/lib/Fixme/Scan.hs b/fixme-new/lib/Fixme/Scan.hs index 1b5ad4fa..90faaf1a 100644 --- a/fixme-new/lib/Fixme/Scan.hs +++ b/fixme-new/lib/Fixme/Scan.hs @@ -26,9 +26,9 @@ import Streaming.Prelude qualified as S data SfEnv = - SfEnv { lno :: Int - , l0 :: Int - , eln :: Int + SfEnv { lno :: Int -- ^ line number + , l0 :: Int -- ^ fixme indent + , eln :: Int -- ^ empty lines counter } deriving stock Generic diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index 3073696e..087c7f54 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -1 +1,122 @@ -module Fixme.State where \ No newline at end of file +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Fixme.State + ( evolve + , withState + , insertFixme + ) where + +import Fixme.Prelude +import Fixme.Types +import Fixme.Config + +import HBS2.System.Dir + +import DBPipe.SQLite + +import Data.HashMap.Strict qualified as HM +import Text.InterpolatedString.Perl6 (qc) + +instance ToField HashRef where + toField x = toField $ show $ pretty x + +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 + createTables + +withState :: forall m a . (FixmePerks m, MonadReader FixmeEnv m) => DBPipeM m a -> m a +withState what = do + db <- asks fixmeEnvDb + withDB db what + + +createTables :: FixmePerks m => DBPipeM m () +createTables = do + + -- тут все таблицы будут называться с префиксом + -- fixme, что бы может быть можно было встроить + -- в другую бд, если вдруг понадобится + + ddl [qc| + create table if not exists fixmecommit + ( hash text not null + , ts int not null + , primary key (hash) + ) + |] + + ddl [qc| + create table if not exists fixme + ( id text not null + , fixme blob not null + , primary key (id) + ) + |] + + ddl [qc| + create table if not exists fixmeattr + ( fixme text not null + , ts integer null + , name text not null + , value text + , primary key (fixme,ts,name) + ) + |] + + ddl [qc| drop view if exists fixmeattrview |] + + ddl [qc| + create view fixmeattrview as + with ranked as ( + select + fixme, + name, + value, + row_number() over (partition by fixme, name order by ts desc nulls first) as rn + from fixmeattr + ) + select + fixme, + name, + value + from ranked + where rn = 1; + |] + +insertFixme :: FixmePerks m => Fixme -> DBPipeM m () +insertFixme fx@Fixme{..} = do + let fixme = serialise fx + let fxId = hashObject @HbSync fixme & HashRef + insert [qc|insert into fixme (id, fixme) values (?,?) + on conflict(id) do nothing + |] (fxId, fixme) + + for_ (HM.toList fixmeAttr) $ \(n,v) -> do + insert [qc| + insert into fixmeattr(fixme,ts,name,value) + values (?,?,?,?) + on conflict (fixme,ts,name) do update set value = excluded.value + |] (fxId, fixmeTs, n, v) + + insert [qc| + insert into fixmeattr(fixme,ts,name,value) + values (?,?,?,?) + on conflict (fixme,ts,name) do update set value = excluded.value + |] (fxId, fixmeTs, "fixme-tag", fixmeTag) + + insert [qc| + insert into fixmeattr(fixme,ts,name,value) + values (?,?,?,?) + on conflict (fixme,ts,name) do update set value = excluded.value + |] (fxId, fixmeTs, "fixme-title", fixmeTitle) + + diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index fb763499..68113718 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -2,6 +2,7 @@ module Fixme.Types where import Fixme.Prelude + import DBPipe.SQLite import HBS2.Git.Local @@ -81,6 +82,7 @@ type FixmePerks m = ( MonadUnliftIO m data FixmeEnv = FixmeEnv { fixmeEnvGitDir :: Maybe FilePath + , fixmeEnvDb :: DBPipeEnv , fixmeEnvFileMask :: TVar [FilePattern] , fixmeEnvTags :: TVar (HashSet FixmeTag) , fixmeEnvAttribs :: TVar (HashSet FixmeAttrName) @@ -126,31 +128,6 @@ newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a } withFixmeEnv :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a withFixmeEnv env what = runReaderT ( fromFixmeM what) env -runFixmeCLI :: FixmePerks m => FixmeM m a -> m a -runFixmeCLI m = do - env <- FixmeEnv Nothing - <$> newTVarIO mempty - <*> newTVarIO mempty - <*> newTVarIO mempty - <*> newTVarIO mempty - <*> newTVarIO mempty - <*> newTVarIO defCommentMap - <*> newTVarIO Nothing - - runReaderT ( setupLogger >> fromFixmeM m ) env - `finally` flushLoggers - where - setupLogger = do - setLogging @ERROR $ toStderr . logPrefix "[error] " - setLogging @WARN $ toStderr . logPrefix "[warn] " - setLogging @NOTICE $ toStdout . logPrefix "" - pure () - - flushLoggers = do - setLoggingOff @DEBUG - setLoggingOff @ERROR - setLoggingOff @WARN - setLoggingOff @NOTICE instance Serialise GitLocation instance Serialise FixmeSource @@ -176,6 +153,8 @@ instance FromField GitRef where instance FromField GitHash where fromField = fmap fromString . fromField @String +instance Pretty FixmeTimestamp where + pretty = pretty . coerce @_ @Word64 instance Pretty FixmeOffset where pretty = pretty . coerce @_ @Word32