voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip, cat command and pager

This commit is contained in:
Dmitry Zuikov 2024-05-14 12:41:15 +03:00
parent f561fb0ce4
commit dd1361c7ef
6 changed files with 137 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.fixme-new/config
View File

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

2
.fixme-new/log Normal file
View File

@ -0,0 +1,2 @@
deleted "6R2raAzjbViHZVk24zwUr7rwgfepHTdXeW6Lbqw3q25A"
deleted "DtcQir9mHe7R5ixYGXTbsXGPeVGV8TqAMmrvYgGy1wGB"

12
fixme-new/lib/Fixme/Config.hs
View File

@ -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"

110
fixme-new/lib/Fixme/Run.hs
View File

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

29
fixme-new/lib/Fixme/Types.hs
View File

@ -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" ]

3
hbs2-core/lib/HBS2/System/Dir.hs
View File

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