wip

fixme-new/lib/Fixme/Run.hs

@@ -12,6 +12,7 @@ import HBS2.Git.Local.CLI
 import HBS2.System.Dir
 
 import Data.Config.Suckless
+import Data.Text.Fuzzy.Tokenize
 
 import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Data.Either
@@ -21,25 +22,47 @@ import Data.HashSet qualified as HS
 import Data.HashMap.Strict qualified as HM
 import Data.Text qualified as Text
 import Text.InterpolatedString.Perl6 (qc)
+import Data.Coerce
+import Control.Monad.Identity
 
+import Streaming.Prelude qualified as S
 
 {- HLINT ignore "Functor law" -}
 
 pattern Init :: forall {c}. Syntax c
 pattern Init <- ListVal [SymbolVal "init"]
 
-pattern ScanGitLocal :: forall {c}. Syntax c
+pattern ScanGitLocal :: forall {c}. [ScanGitArgs] -> Syntax c
-pattern ScanGitLocal <- ListVal [SymbolVal "scan-git"]
+pattern ScanGitLocal e <- ListVal (SymbolVal "scan-git" : (scanGitArgs -> e))
+
+pattern ReadFixmeStdin :: forall {c}.  Syntax c
+pattern ReadFixmeStdin <- ListVal [SymbolVal "read-fixme-stdin"]
 
 pattern FixmeFiles :: forall {c} . [FilePattern] -> Syntax c
 pattern FixmeFiles e  <- ListVal (SymbolVal "fixme-files" : (fileMasks -> e))
 
+
+pattern FixmePrefix :: forall {c} . FixmeTag -> Syntax c
+pattern FixmePrefix s <- ListVal [SymbolVal "fixme-prefix", fixmePrefix -> Just s]
+
 pattern FixmeGitScanFilterDays :: forall {c}. Integer -> Syntax c
 pattern FixmeGitScanFilterDays d <- ListVal [ SymbolVal "fixme-git-scan-filter-days", LitIntVal d ]
 
+data ScanGitArgs =
+  PrintBlobs
+  deriving stock (Eq,Ord,Show,Data,Generic)
+
+scanGitArgs :: [Syntax c] -> [ScanGitArgs]
+scanGitArgs syn = [ PrintBlobs | SymbolVal "print-blobs" <- syn ]
+
 fileMasks :: [Syntax c] -> [FilePattern]
 fileMasks what = [ show (pretty s) | s <- what ]
 
+fixmePrefix :: Syntax c -> Maybe FixmeTag
+fixmePrefix = \case
+  SymbolVal s -> Just (FixmeTag (coerce s))
+  _ -> Nothing
+
 binName :: FixmePerks m => m FilePath
 binName = liftIO getProgName
 
@@ -122,28 +145,65 @@ 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 => Maybe FilePath -> FixmeM m ()
+scanGitLocal :: FixmePerks m => [ScanGitArgs] -> Maybe FilePath -> FixmeM m ()
-scanGitLocal p =  do
+scanGitLocal args p =  do
   debug $ yellow "scan for fixmies, wtf?"
   co <- listCommits
-  for_ co $ \c -> do
+
-    blobs <- listBlobs c >>= filterBlobs
+  blobs <- mconcat <$> for co (\c -> do
-    debug $ vcat (fmap pretty blobs)
+                          listBlobs c >>= filterBlobs )
+
+  when (PrintBlobs `elem` args) do
+    for_ blobs $ \(fp,h) -> do
+      liftIO $ print $ pretty h <+> pretty fp
+
+readFixmeStdin :: FixmePerks m => FixmeM m ()
+readFixmeStdin = do
+  pure ()
+
+printEnv :: FixmePerks m => FixmeM m ()
+printEnv = do
+  g <- asks fixmeEnvGitDir
+  masks <- asks fixmeEnvFileMask >>= readTVarIO
+  tags  <- asks fixmeEnvTags >>= readTVarIO
+  days  <- asks fixmeEnvGitScanDays >>= readTVarIO
+
+  for_ tags $ \m -> do
+    liftIO $ print $ "fixme-prefix" <+> pretty m
+
+  for_ masks $ \m -> do
+    liftIO $ print $ "fixme-files" <+> dquotes (pretty m)
+
+  for_ days $ \d -> do
+    liftIO $ print $ "fixme-git-scan-filter-days" <+> pretty d
 
 help :: FixmePerks m => m ()
 help = do
   notice "this is help  message"
 
+
+splitForms :: [String] -> [[String]]
+splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
+  where
+    go acc ( "then" : rest ) = emit acc >> go mempty rest
+    go acc ( x : rest ) = go ( x : acc ) rest
+    go acc [] = emit acc
+
+    emit = S.yield . reverse
+
 run :: FixmePerks m => [String] -> FixmeM m ()
 run what = do
 
   sc <- readConfig
 
-  let s0 = parseTop (unwords what)
+  let s0 = fmap (parseTop . unwords) (splitForms what)
-            & fromRight mempty
+             & rights
-            & (sc <>)
+             & mconcat
 
-  for_ s0 $ \s -> do
+
+  for_ (sc <> s0) $ \s -> do
+
+    debug $ pretty s
 
     case s of
 
@@ -151,13 +211,28 @@ run what = do
         t <- asks fixmeEnvFileMask
         atomically (modifyTVar t (<> xs))
 
+      FixmePrefix tag -> do
+        t <- asks fixmeEnvTags
+        atomically (modifyTVar t (HS.insert tag))
+
       FixmeGitScanFilterDays d -> do
         t <- asks fixmeEnvGitScanDays
         atomically (writeTVar t (Just d))
 
       Init         -> init
 
-      ScanGitLocal -> scanGitLocal Nothing
+      ScanGitLocal args -> scanGitLocal args Nothing
+
+      ReadFixmeStdin -> readFixmeStdin
+
+      ListVal [SymbolVal "print-env"] -> do
+        printEnv
+
+      ListVal [SymbolVal "no-debug"] -> do
+        setLoggingOff @DEBUG
+
+      ListVal [SymbolVal "debug"] -> do
+        setLogging @DEBUG  $ toStderr . logPrefix "[debug] "
 
       w         -> err (pretty w)
 

fixme-new/lib/Fixme/Types.hs

@@ -2,11 +2,10 @@ module Fixme.Types where
 
 import Fixme.Prelude
 
-import HBS2.System.Logger.Simple.ANSI
-
 import Data.HashMap.Strict (HashMap)
+import Data.HashSet (HashSet)
 import Data.Word (Word64)
-import Control.Monad.Reader
+import Data.Coerce
 
 data GitLocation =
   GitLocation
@@ -21,7 +20,7 @@ data FixmeSource =
   deriving stock (Show,Data,Generic)
 
 newtype FixmeTag = FixmeTag { fromFixmeTag :: Text }
-                   deriving newtype (Eq,Ord,Show,IsString)
+                   deriving newtype (Eq,Ord,Show,IsString,Hashable)
                    deriving stock (Data,Generic)
 
 newtype FixmeTitle = FixmeTitle { fromFixmeTitle :: Text }
@@ -68,6 +67,7 @@ data FixmeEnv =
   FixmeEnv
   { fixmeEnvGitDir      :: Maybe FilePath
   , fixmeEnvFileMask    :: TVar [FilePattern]
+  , fixmeEnvTags        :: TVar (HashSet FixmeTag)
   , fixmeEnvGitScanDays :: TVar (Maybe Integer)
   }
 
@@ -84,13 +84,13 @@ runFixmeCLI :: FixmePerks m => FixmeM m a -> m a
 runFixmeCLI m = do
   env <- FixmeEnv Nothing
             <$>  newTVarIO mempty
+            <*>  newTVarIO mempty
             <*>  newTVarIO Nothing
 
   runReaderT ( setupLogger >> fromFixmeM m ) env
                  `finally` flushLoggers
   where
     setupLogger = do
-      setLogging @DEBUG  $ toStderr . logPrefix "[debug] "
       setLogging @ERROR  $ toStderr . logPrefix "[error] "
       setLogging @WARN   $ toStderr . logPrefix "[warn] "
       setLogging @NOTICE $ toStdout . logPrefix ""
@@ -113,3 +113,9 @@ instance Serialise FixmeTimestamp
 instance Serialise Fixme
 
 
+instance Pretty FixmeTitle where
+  pretty = pretty . coerce @_ @Text
+
+instance Pretty FixmeTag where
+  pretty = pretty . coerce @_ @Text
+