voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-05-12 09:04:51 +03:00
parent b533e2ac46
commit 09ebc4fc0d
7 changed files with 234 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
fixme-new/fixme.cabal
View File

@ -101,6 +101,7 @@ library
exposed-modules:
Fixme
Fixme.Config
Fixme.Run
Fixme.Types
Fixme.Prelude

26
fixme-new/lib/Fixme/Config.hs Normal file
View File

@ -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)

5
fixme-new/lib/Fixme/Prelude.hs
View File

@ -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

122
fixme-new/lib/Fixme/Run.hs
View File

@ -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] "

6
fixme-new/lib/Fixme/Scan.hs
View File

@ -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

123
fixme-new/lib/Fixme/State.hs
View File

@ -1 +1,122 @@
module Fixme.State where
{-# 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)

29
fixme-new/lib/Fixme/Types.hs
View File

@ -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