From 47d298378b03fab346eaf976955d094aaf1013f4 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 9 May 2024 09:10:40 +0300 Subject: [PATCH] wip --- fixme-new/app/FixmeMain.hs | 6 +- fixme-new/fixme.cabal | 9 +-- fixme-new/lib/Fixme/Prelude.hs | 10 ++- fixme-new/lib/Fixme/Run.hs | 114 ++++++++++++++++++++++++++++++++ fixme-new/lib/Fixme/Scan/Git.hs | 12 ++++ fixme-new/lib/Fixme/State.hs | 1 + fixme-new/lib/Fixme/Types.hs | 101 +++++++++++++++++++++++++++- 7 files changed, 244 insertions(+), 9 deletions(-) create mode 100644 fixme-new/lib/Fixme/Run.hs create mode 100644 fixme-new/lib/Fixme/Scan/Git.hs create mode 100644 fixme-new/lib/Fixme/State.hs diff --git a/fixme-new/app/FixmeMain.hs b/fixme-new/app/FixmeMain.hs index c11d94c0..d5ee2e3d 100644 --- a/fixme-new/app/FixmeMain.hs +++ b/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) diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index 83d8de93..fac3bb36 100644 --- a/fixme-new/fixme.cabal +++ b/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 diff --git a/fixme-new/lib/Fixme/Prelude.hs b/fixme-new/lib/Fixme/Prelude.hs index 9e5d017f..ce95d562 100644 --- a/fixme-new/lib/Fixme/Prelude.hs +++ b/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 diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs new file mode 100644 index 00000000..35437d24 --- /dev/null +++ b/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 + + diff --git a/fixme-new/lib/Fixme/Scan/Git.hs b/fixme-new/lib/Fixme/Scan/Git.hs new file mode 100644 index 00000000..ca630ee8 --- /dev/null +++ b/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 + + diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs new file mode 100644 index 00000000..3073696e --- /dev/null +++ b/fixme-new/lib/Fixme/State.hs @@ -0,0 +1 @@ +module Fixme.State where \ No newline at end of file diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index eb916ebf..b9a467b9 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/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 + +