wip

fixme-new/fixme.cabal

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

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

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

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
+runFixmeCLI :: FixmePerks m => FixmeM m a -> m a
-localConfigDir = do
+runFixmeCLI m = do
-  p <- pwd
+  db <- newDBPipeEnv dbPipeOptsDef =<< localDBPath
-  b <- binName
+  env <- FixmeEnv Nothing db
-  pure (p </> ("." <> b))
+            <$>  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] "
 

fixme-new/lib/Fixme/Scan.hs

@@ -26,9 +26,9 @@ import Streaming.Prelude qualified as S
 
 
 data SfEnv =
-  SfEnv { lno :: Int
+  SfEnv { lno :: Int  -- ^ line number
-        , l0  :: Int
+        , l0  :: Int  -- ^ fixme indent
-        , eln :: Int
+        , eln :: Int  -- ^ empty lines counter
         }
         deriving stock Generic
 

fixme-new/lib/Fixme/State.hs

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

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