From dd1361c7ef0a7ee80a929352233928e961572674 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 14 May 2024 12:41:15 +0300 Subject: [PATCH] wip, cat command and pager --- .fixme-new/config | 3 + .fixme-new/log | 2 + fixme-new/lib/Fixme/Config.hs | 12 ++++ fixme-new/lib/Fixme/Run.hs | 110 ++++++++++++++++++++++++++----- fixme-new/lib/Fixme/Types.hs | 29 ++++++-- hbs2-core/lib/HBS2/System/Dir.hs | 3 + 6 files changed, 137 insertions(+), 22 deletions(-) create mode 100644 .fixme-new/log diff --git a/.fixme-new/config b/.fixme-new/config index cd6efdfe..6837ea64 100644 --- a/.fixme-new/config +++ b/.fixme-new/config @@ -38,6 +38,7 @@ fixme-comments ";" "--" ) (fixme-play-log-action +; (hello kitty) ) (define-template short @@ -61,6 +62,8 @@ fixme-comments ";" "--" ) ) +(set-template default short) + ; update diff --git a/.fixme-new/log b/.fixme-new/log new file mode 100644 index 00000000..23b84e0f --- /dev/null +++ b/.fixme-new/log @@ -0,0 +1,2 @@ +deleted "6R2raAzjbViHZVk24zwUr7rwgfepHTdXeW6Lbqw3q25A" +deleted "DtcQir9mHe7R5ixYGXTbsXGPeVGV8TqAMmrvYgGy1wGB" diff --git a/fixme-new/lib/Fixme/Config.hs b/fixme-new/lib/Fixme/Config.hs index 4b1b8ae5..db93590a 100644 --- a/fixme-new/lib/Fixme/Config.hs +++ b/fixme-new/lib/Fixme/Config.hs @@ -5,6 +5,7 @@ import Fixme.Types import HBS2.System.Dir import System.Environment +import System.Directory binName :: FixmePerks m => m FilePath binName = liftIO getProgName @@ -18,6 +19,17 @@ localConfigDir = do localConfig:: FixmePerks m => m FilePath localConfig = localConfigDir <&> ( "config") +userConfigs :: FixmePerks m => m [FilePath] +userConfigs= do + bin <- binName + h <- home + xdg <- liftIO (getXdgDirectory XdgConfig bin) + + let conf1 = h ("." <> bin) + let conf2 = xdg "config" + + pure [conf2, conf1] + localDBName :: FilePath localDBName = "state.db" diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index bf2f5b40..7e6fcf86 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -134,7 +134,9 @@ runFixmeCLI m = do <*> newTVarIO Nothing <*> newTVarIO mempty <*> newTVarIO mempty + <*> newTVarIO defaultCatAction <*> newTVarIO defaultTemplate + <*> newTVarIO (1,3) runReaderT ( setupLogger >> fromFixmeM (evolve >> m) ) env `finally` flushLoggers @@ -148,6 +150,10 @@ runFixmeCLI m = do flushLoggers = do silence + -- FIXME: tied-fucking-context + defaultCatAction = CatAction $ \dict lbs -> do + LBS.putStr lbs + pure () silence :: FixmePerks m => m () silence = do @@ -160,11 +166,17 @@ silence = do readConfig :: FixmePerks m => FixmeM m [Syntax C] readConfig = do - localConfig - >>= try @_ @IOException . liftIO . readFile - <&> fromRight mempty - <&> parseTop - <&> fromRight mempty + + user <- userConfigs + lo <- localConfig + + w <- for (lo : user) $ \conf -> do + try @_ @IOException (liftIO $ readFile conf) + <&> fromRight mempty + <&> parseTop + <&> fromRight mempty + + pure $ mconcat w init :: FixmePerks m => FixmeM m () init = do @@ -503,28 +515,58 @@ list_ tpl a = do Just (Simple (SimpleTemplate simple)) -> do for_ fixmies $ \(FixmeThin attr) -> do - let subst = [ (mksym k, mkstr v) | (k,v) <- HM.toList attr ] + let subst = [ (mksym k, mkstr @C v) | (k,v) <- HM.toList attr ] let what = render (SimpleTemplate (inject subst simple)) & fromRight "render error" liftIO $ hPutDoc stdout what - where - mksym (k :: FixmeAttrName) = Id ("$" <> coerce k) - mkstr (s :: FixmeAttrVal) = Literal cc (LitStr (coerce s)) - cc = noContext :: Context C cat_ :: FixmePerks m => Text -> FixmeM m () -cat_ hash = void $ flip runContT pure do - callCC \exit -> do +cat_ hash = do - mha <- lift $ selectFixmeHash hash + (before,after) <- asks fixmeEnvCatContext >>= readTVarIO + gd <- fixmeGetGitDirCLIOpt - ha <- ContT $ maybe1 mha (pure ()) + CatAction action <- asks fixmeEnvCatAction >>= readTVarIO - fme <- lift $ selectFixme ha + void $ flip runContT pure do + callCC \exit -> do - notice $ pretty fme + mha <- lift $ selectFixmeHash hash + + ha <- ContT $ maybe1 mha (pure ()) + + fme' <- lift $ selectFixme ha + + Fixme{..} <- ContT $ maybe1 fme' (pure ()) + + let gh' = HM.lookup "blob" fixmeAttr + + -- FIXME: define-fallback-action + gh <- ContT $ maybe1 gh' none + + let cmd = [qc|git {gd} cat-file blob {pretty gh}|] :: String + + let start = fromMaybe 0 fixmeStart & fromIntegral & (\x -> x - before) & max 0 + let bbefore = if start > before then before + 1 else 1 + let origLen = maybe 0 fromIntegral fixmeEnd - maybe 0 fromIntegral fixmeStart & max 1 + let lno = max 1 $ origLen + after + before + + let dict = [ (mksym k, mkstr @C v) | (k,v) <- HM.toList fixmeAttr ] + <> + [ (mksym "before", mkstr @C (FixmeAttrVal $ Text.pack $ show bbefore)) + ] + + debug (pretty cmd) + + w <- gitRunCommand cmd + <&> either (LBS8.pack . show) id + <&> LBS8.lines + <&> drop start + <&> take lno + + liftIO $ action dict (LBS8.unlines w) delete :: FixmePerks m => Text -> FixmeM m () delete txt = do @@ -580,6 +622,12 @@ printEnv = do for_ vals$ \(v, vs) -> do liftIO $ print $ "fixme-value-set" <+> pretty v <+> hsep (fmap pretty (HS.toList vs)) + + (before,after) <- asks fixmeEnvCatContext >>= readTVarIO + + liftIO $ print $ "fixme-def-context" <+> pretty before <+> pretty after + + help :: FixmePerks m => m () help = do notice "this is help message" @@ -659,6 +707,30 @@ run what = do ta <- asks fixmeEnvAttribs atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs)) + ListVal [SymbolVal "fixme-def-context", LitIntVal a, LitIntVal b] -> do + t <- asks fixmeEnvCatContext + atomically $ writeTVar t (fromIntegral a, fromIntegral b) + + ListVal [SymbolVal "fixme-pager", ListVal cmd0] -> do + t <- asks fixmeEnvCatAction + let action = CatAction $ \dict lbs -> do + + let ccmd = case inject dict cmd0 of + (StringLike p : StringLikeList xs) -> Just (p, xs) + _ -> Nothing + + + debug $ pretty ccmd + + maybe1 ccmd none $ \(p, args) -> do + + let input = byteStringInput lbs + let cmd = setStdin input $ setStderr closed + $ proc p args + void $ runProcess cmd + + atomically $ writeTVar t action + ListVal (SymbolVal "fixme-value-set" : StringLike n : StringLikeList xs) -> do t <- asks fixmeEnvAttribValues let name = fromString n @@ -701,6 +773,12 @@ run what = do t <- asks fixmeEnvTemplates atomically $ modifyTVar t (HM.insert who (Simple (SimpleTemplate xs))) + ListVal [SymbolVal "set-template", SymbolVal who, SymbolVal w] -> do + templates <- asks fixmeEnvTemplates + t <- readTVarIO templates + for_ (HM.lookup w t) $ \tpl -> do + atomically $ modifyTVar templates (HM.insert who tpl) + -- FIXME: maybe-rename-fixme-update-action ListVal (SymbolVal "fixme-update-action" : xs) -> do debug $ "fixme-update-action" <+> pretty xs diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 1403a045..1dba61c2 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -14,6 +14,7 @@ import Data.Config.Suckless import Prettyprinter.Render.Terminal import Control.Applicative import Data.Aeson +import Data.ByteString.Lazy (ByteString) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM import Data.HashSet (HashSet) @@ -91,6 +92,7 @@ newtype FixmeKey = FixmeKey Text newtype FixmeOffset = FixmeOffset Word32 deriving newtype (Eq,Ord,Show,Num,ToField,FromField) + deriving newtype (Integral,Real,Enum) deriving stock (Data,Generic) @@ -134,7 +136,9 @@ data UpdateAction = forall c . IsContext c => UpdateAction { runUpdateAction :: data ReadLogAction = forall c . IsContext c => ReadLogAction { runReadLog :: Syntax c -> IO () } --- FIXME: fucking-context-hardcode-wtf +-- FIXME: fucking-context-hardcode-wtf-1 +data CatAction = CatAction { catAction :: [(Id, Syntax C)] -> ByteString -> IO () } + data SimpleTemplate = forall c . (IsContext c, Data (Context c), Data c) => SimpleTemplate [Syntax c] data FixmeTemplate = @@ -159,7 +163,9 @@ data FixmeEnv = , fixmeEnvGitScanDays :: TVar (Maybe Integer) , fixmeEnvUpdateActions :: TVar [UpdateAction] , fixmeEnvReadLogActions :: TVar [ReadLogAction] + , fixmeEnvCatAction :: TVar CatAction , fixmeEnvTemplates :: TVar (HashMap Id FixmeTemplate) + , fixmeEnvCatContext :: TVar (Int,Int) } @@ -294,7 +300,18 @@ commentKey fp = "" -> takeFileName fp xs -> xs -inject :: forall c a . (IsContext c, Data c, Data (Context c), Data a) => [(Id,Syntax c)] -> a -> a +type ContextShit c = (Data c, Data (Context c), IsContext c) + +mksym :: FixmeAttrName -> Id +mksym (k :: FixmeAttrName) = Id ("$" <> coerce k) + +mkstr :: forall c . (IsContext c) => FixmeAttrVal -> Syntax c +mkstr (s :: FixmeAttrVal) = Literal (noContext @c) (LitStr (coerce s)) + +cc0 :: forall c . ContextShit c => Context c +cc0 = noContext :: Context c + +inject :: forall c a . (ContextShit c, Data a) => [(Id,Syntax c)] -> a -> a inject repl target = flip transformBi target $ \case (SymbolVal x) | issubst x -> fromMaybe mt (Map.lookup x rmap) @@ -341,7 +358,7 @@ instance FixmeRenderTemplate SimpleTemplate (Doc AnsiStyle) where where - evaluated :: (IsContext c, Data (Context c), Data c) => Syntax c -> Maybe Text + evaluated :: (ContextShit c) => Syntax c -> Maybe Text evaluated what = Just (deep' [what] & Text.concat) color_ = \case @@ -377,10 +394,10 @@ instance FixmeRenderTemplate SimpleTemplate (Doc AnsiStyle) where n = fromIntegral n0 s = mconcat s0 - deep :: forall c . (IsContext c, Data (Context c), Data c) => [Syntax c] -> [Doc AnsiStyle] + deep :: forall c . (ContextShit c) => [Syntax c] -> [Doc AnsiStyle] deep sy = either mempty List.singleton (render (SimpleTemplate sy)) - deep' :: forall c . (IsContext c, Data (Context c), Data c) => [Syntax c] -> [Text] + deep' :: forall c . (ContextShit c) => [Syntax c] -> [Text] deep' sy = do let what = deep sy [ Text.pack (show x) | x <- what] @@ -417,7 +434,7 @@ instance FixmeRenderTemplate SimpleTemplate Text where n = fromIntegral n0 s = mconcat s0 - deep :: forall c . (IsContext c, Data (Context c), Data c) => [Syntax c] -> [Text] + deep :: forall c . (ContextShit c) => [Syntax c] -> [Text] deep sy = either mempty List.singleton (render (SimpleTemplate sy)) nl = [ "\n" ] diff --git a/hbs2-core/lib/HBS2/System/Dir.hs b/hbs2-core/lib/HBS2/System/Dir.hs index e3df6bb7..ca7a83c0 100644 --- a/hbs2-core/lib/HBS2/System/Dir.hs +++ b/hbs2-core/lib/HBS2/System/Dir.hs @@ -69,4 +69,7 @@ expandPath = liftIO . D.canonicalizePath doesDirectoryExist :: MonadIO m => FilePath -> m Bool doesDirectoryExist = liftIO . D.doesDirectoryExist +home :: MonadIO m => m FilePath +home = liftIO D.getHomeDirectory +