wip

fixme-new/app/FixmeMain.hs

@@ -1,6 +1,8 @@
 module Main where
 
 import Fixme
+import Fixme.Run
+import System.Environment
 
 -- TODO: fixme-new
 --  после майских:
@@ -43,10 +45,8 @@ import Fixme
 
 -- встроить ли jq внутрь или лучше дать доступ к sql запросам по json
 
-
 main :: IO ()
 main = do
-  print "HI, DUDE"
 
   -- TODO: discover-config
   --
@@ -59,5 +59,5 @@ main = do
   -- TODO: scan-all-sources
   --   for-source-from-con
 
-  -- TODO:
+  runFixmeCLI (run =<< liftIO getArgs)
 

fixme-new/fixme.cabal

@@ -56,8 +56,10 @@ common shared-properties
       , hbs2-peer
       , hbs2-storage-simple
       , hbs2-keyman
+      , hbs2-git
       , db-pipe
       , suckless-conf
+      , fuzzy-parse
 
       , attoparsec
       , atomic-write
@@ -97,14 +99,13 @@ library
 
     exposed-modules:
       Fixme
+      Fixme.Run
       Fixme.Types
       Fixme.Prelude
+      Fixme.State
+      Fixme.Scan.Git
 
     build-depends:    base
-                    , hbs2-core
-                    , hbs2-peer
-                    , fuzzy-parse
-                    , suckless-conf
                     , base16-bytestring
                     , binary
                     , unix

fixme-new/lib/Fixme/Prelude.hs

@@ -1,7 +1,15 @@
 module Fixme.Prelude
   ( module All
+  , GitHash(..)
+  , Serialise(..)
   ) where
 
 import HBS2.Prelude.Plated 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 Data.Functor as All
+import Data.Function as All
+import UnliftIO as All
 

fixme-new/lib/Fixme/Run.hs

@@ -0,0 +1,114 @@
+{-# Language PatternSynonyms #-}
+module Fixme.Run where
+
+import Prelude hiding (init)
+import Fixme.Prelude
+import Fixme.Types
+import Fixme.Scan.Git as Git
+
+import HBS2.Git.Local.CLI
+
+import HBS2.System.Dir
+
+import Data.Config.Suckless
+
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.Either
+import System.Environment
+import Data.Maybe
+import Text.InterpolatedString.Perl6 (qc)
+import Lens.Micro.Platform
+
+{- HLINT ignore "Functor law" -}
+
+pattern Init :: forall {c}. Syntax c
+pattern Init <- ListVal [SymbolVal "init"]
+
+pattern ScanGitLocal :: forall {c}. Syntax c
+pattern ScanGitLocal <- ListVal [SymbolVal "scan-git"]
+
+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")
+
+init :: FixmePerks m => FixmeM m ()
+init = do
+  lo <- localConfigDir
+
+  let lo0 = takeFileName lo
+
+  touch (lo </> "config")
+  mkdir lo
+
+  let gitignore = lo </> ".gitignore"
+  here <- doesPathExist gitignore
+
+  unless here do
+    liftIO $ writeFile gitignore $ show $
+      vcat [ "./state.db"
+           ]
+
+  notice $ yellow "run" <> line <> vcat [
+      "git add" <+> pretty (lo0  </> ".gitignore")
+    , "git add" <+> pretty (lo0  </> "config")
+    ]
+
+listCommits :: FixmePerks m => m [GitHash]
+listCommits = do
+  let gd = ""
+  -- FIXME: git-dir
+  gitRunCommand [qc|git rev-list --all|]
+    <&> fromRight mempty
+    <&> mapMaybe (headMay . LBS8.words) . LBS8.lines
+    <&> mapMaybe (fromStringMay @GitHash . LBS8.unpack)
+
+
+listBlobs :: FixmePerks m => GitHash -> m [(FilePath, GitHash)]
+listBlobs co = do
+  -- FIXME: git-dir
+  gitRunCommand [qc|git ls-tree -r -l -t {pretty co}|]
+    <&> fromRight mempty
+    <&> fmap LBS8.words . LBS8.lines
+    <&> mapMaybe
+          (\case
+             [a,_,h,_,fn] -> (LBS8.unpack fn,) <$> fromStringMay @GitHash (LBS8.unpack h)
+             _                 -> Nothing)
+
+
+scanGitLocal :: FixmePerks m => Maybe FilePath -> m ()
+scanGitLocal p = do
+  debug $ yellow "scan for fixmies, wtf?"
+  co <- listCommits
+  for_ co $ \c -> do
+    blobs <- listBlobs c
+    debug $ vcat (fmap pretty blobs)
+
+help :: FixmePerks m => m ()
+help = do
+  notice "this is help  message"
+
+run :: FixmePerks m => [String] -> FixmeM m ()
+run what = do
+
+  let s0 = parseTop (unwords what)
+             & fromRight mempty
+
+  debug $ pretty  s0
+
+  case s0 of
+    [Init]         -> init
+
+    [ScanGitLocal] -> scanGitLocal Nothing
+
+
+    _         -> help
+
+

fixme-new/lib/Fixme/Scan/Git.hs

@@ -0,0 +1,12 @@
+module Fixme.Scan.Git where
+
+import Fixme.Types
+
+import HBS2.Git.Local
+
+
+scanForFixmies :: FixmePerks m => Maybe FilePath -> m [Fixme]
+scanForFixmies _ = do
+  pure  mempty
+
+

fixme-new/lib/Fixme/State.hs

@@ -0,0 +1 @@
+module Fixme.State where

fixme-new/lib/Fixme/Types.hs

@@ -2,8 +2,107 @@ module Fixme.Types where
 
 import Fixme.Prelude
 
+import HBS2.System.Logger.Simple.ANSI
+
+import Data.HashMap.Strict (HashMap)
+import Data.Word (Word64)
+import Control.Monad.Reader
+
+data GitLocation =
+  GitLocation
+  { gitLocationHash   :: GitHash
+  , gitLocationOffset :: Integer
+  , gitLocationLength :: Integer
+  }
+  deriving stock (Eq,Ord,Show,Data,Generic)
+
+data FixmeSource =
+  FixmeSourceGit GitLocation
+  deriving stock (Show,Data,Generic)
+
+newtype FixmeTag = FixmeTag { fromFixmeTag :: Text }
+                   deriving newtype (Eq,Ord,Show,IsString)
+                   deriving stock (Data,Generic)
+
+newtype FixmeTitle = FixmeTitle { fromFixmeTitle :: Text }
+                     deriving newtype (Eq,Ord,Show,IsString)
+                     deriving stock (Data,Generic)
+
+newtype FixmePlainLine = FixmePlainLine { fromFixmeText :: Text }
+                         deriving newtype (Eq,Ord,Show,IsString)
+                         deriving stock (Data,Generic)
+
+
+newtype FixmeAttrName = FixmeAttrName { fromFixmeAttrName :: Text }
+                        deriving newtype (Eq,Ord,Show,IsString,Hashable)
+                        deriving stock (Data,Generic)
+
+
+newtype FixmeAttrVal = FixmeAttrVal { fromFixmeAttrVal :: Text }
+                        deriving newtype (Eq,Ord,Show,IsString)
+                        deriving stock (Data,Generic)
+
+
+newtype FixmeTimestamp = FixmeTimestamp Word64
+                        deriving newtype (Eq,Ord,Show)
+                        deriving stock (Data,Generic)
+
 data Fixme =
   Fixme
-  {
+  { fixmeTag    :: FixmeTag
+  , fixmeTitle  :: FixmeTitle
+  , fixmeTs     :: FixmeTimestamp
+  , fixmePlain  :: [FixmePlainLine]
+  , fixmeAttr   :: HashMap FixmeAttrName FixmeAttrVal
+  , fixmeSource :: Maybe FixmeSource
+  }
+  deriving stock (Show,Data,Generic)
+
+
+type FixmePerks m = ( MonadUnliftIO m
+                    , MonadIO m
+                    )
+
+
+data FixmeEnv =
+  FixmeEnv
+  { fixmeEnvGitDir :: Maybe FilePath
   }
 
+newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a }
+                     deriving newtype ( Applicative
+                                      , Functor
+                                      , Monad
+                                      , MonadIO
+                                      , MonadUnliftIO
+                                      , MonadReader FixmeEnv
+                                      )
+
+runFixmeCLI :: FixmePerks m => FixmeM m a -> m a
+runFixmeCLI m = runReaderT ( setupLogger >> fromFixmeM m ) (FixmeEnv Nothing)
+                 `finally` flushLoggers
+  where
+    setupLogger = do
+      setLogging @DEBUG  $ toStderr . logPrefix "[debug] "
+      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
+instance Serialise FixmeTag
+instance Serialise FixmeTitle
+instance Serialise FixmePlainLine
+instance Serialise FixmeAttrName
+instance Serialise FixmeAttrVal
+instance Serialise FixmeTimestamp
+instance Serialise Fixme
+
+