From 5324e83031229b55e64d6e7eeb9e05677c6bbf6b Mon Sep 17 00:00:00 2001 From: voidlizard Date: Mon, 7 Oct 2024 05:23:16 +0300 Subject: [PATCH] basic fixme editing --- .fixme-new/config | 3 + fixme-new/fixme.cabal | 1 + fixme-new/lib/Fixme/Run.hs | 34 ++- fixme-new/lib/Fixme/Run/Internal.hs | 77 ++++++ fixme-new/lib/Fixme/Scan.hs | 40 +++- flake.lock | 219 ------------------ flake.nix | 1 + .../Data/Config/Suckless/Script/Internal.hs | 16 ++ 8 files changed, 161 insertions(+), 230 deletions(-) delete mode 100644 flake.lock diff --git a/.fixme-new/config b/.fixme-new/config index 92525400..cfda0c85 100644 --- a/.fixme-new/config +++ b/.fixme-new/config @@ -13,6 +13,8 @@ fixme-attribs assigned workflow :class fixme-attribs class +fixme-attribs :committer-name :commit-time + fixme-value-set :workflow :new :backlog :wip :test :fixed :done :ready :merged fixme-value-set class hardcode performance boilerplate @@ -25,6 +27,7 @@ fixme-files **/*.txt docs/devlog.md fixme-files **/*.hs fixme-exclude **/.** fixme-exclude dist-newstyle +fixme-exclude miscellaneous fixme-file-comments "*.scm" ";" diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index 3fc39f97..b2a7e947 100644 --- a/fixme-new/fixme.cabal +++ b/fixme-new/fixme.cabal @@ -100,6 +100,7 @@ common shared-properties , random , vector , unix + , uuid library diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index a195ec49..c61e06b6 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -59,7 +59,7 @@ import System.Process.Typed import Control.Monad import Control.Monad.Trans.Cont import Control.Monad.Trans.Maybe -import System.IO.Temp as Temp +import System.IO.Temp qualified as Temp import System.IO qualified as IO import Streaming.Prelude qualified as S @@ -325,6 +325,32 @@ runTop forms = do _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "create" $ nil_ $ \syn -> do + + me' <- lookupValue "me" + + me <- case me' of + StringLike who -> pure who + _ -> do + user <- liftIO $ lookupEnv "USER" <&> fromMaybe "stranger" + try @_ @SomeException (readProcess (shell [qc|git config user.name|])) + <&> either (const user) (headDef user . lines . LBS8.unpack . view _2) + + let title = case syn of + StringLikeList xs -> unwords xs + _ -> "new-issue" + + lift $ edit_ (Left (me,title)) + + entry $ bindMatch "edit" $ nil_ $ \case + [ FixmeHashLike w] -> lift $ void $ runMaybeT do + key <- lift (selectFixmeKey w) >>= toMPlus + fme <- lift (getFixme key) >>= toMPlus + lift $ edit_ (Right fme) + + _ -> throwIO $ BadFormException @C nil + entry $ bindMatch "dump" $ nil_ $ \case [ FixmeHashLike w ] -> lift $ void $ runMaybeT do key <- lift (selectFixmeKey w) >>= toMPlus @@ -466,15 +492,13 @@ runTop forms = do debug $ red "SOURCE FILE" <+> pretty ppath - dd <- readTVarIO tvd - -- FIXME: raise-warning? content <- liftIO $ try @_ @IOException (readFile ppath) <&> fromRight mempty <&> parseTop >>= either (error.show) pure - lift $ run dd content + lift $ runEval tvd content _ -> throwIO $ BadFormException @C nil @@ -563,5 +587,5 @@ runTop forms = do atomically $ writeTVar tvd finalDict - run finalDict (conf <> forms) >>= eatNil display + runEval tvd (conf <> forms) >>= eatNil display diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index 49239352..da7da0f6 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -41,6 +41,7 @@ import Data.Either import Data.Map qualified as Map import Data.Set qualified as Set import Data.Maybe +import Data.Generics.Product.Fields (field) import Data.HashSet qualified as HS import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM @@ -49,6 +50,7 @@ import Data.Text.Encoding (encodeUtf8) import Text.InterpolatedString.Perl6 (qc) import Data.Coerce import Data.Word +import Data.UUID.V4 qualified as UUID import Lens.Micro.Platform import System.Process.Typed import Control.Monad.Trans.Cont @@ -58,7 +60,10 @@ import Control.Concurrent.STM (flushTQueue) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import System.Directory (getModificationTime) + import System.IO as IO +import System.Environment (lookupEnv) +import System.IO.Temp qualified as Temp import Streaming.Prelude qualified as S @@ -257,6 +262,11 @@ printEnv = do liftIO $ print $ ("reader" <+> pretty (AsBase58 <$> reader)) +scanOneFile :: FixmePerks m => FilePath -> FixmeM m [Fixme] +scanOneFile fn = do + lbs <- liftIO $ LBS.readFile fn + scanBlob (Just fn) lbs + scanFiles :: FixmePerks m => FixmeM m [Fixme] scanFiles = do w <- fixmeWorkDir @@ -319,6 +329,73 @@ report t q = do liftIO $ hPutDoc stdout what +edit_ :: FixmePerks m + => Either (String,String) Fixme + -> FixmeM m () + +edit_ what = do + + now <- liftIO $ getPOSIXTime <&> round + + editor <- liftIO $ lookupEnv "EDITOR" >>= orThrowUser "EDITOR not set" + + let txt = case what of + Right fx0 -> do + let fxm = fx0 & set (field @"fixmeAttr") mempty + & set (field @"fixmeStart") mzero + & set (field @"fixmeEnd") mzero + show $ pretty fxm + + Left (me,title) -> [qc|TODO: {title} +$commit-time: {pretty now} +$committer-name: {pretty me} + +Issue text... +|] + + let setKey k fx = case what of + Right w -> fx & set (field @"fixmeKey") (fixmeKey w) + Left{} -> fx & set (field @"fixmeKey") (fromString p) + where + p = show $ pretty + $ hashObject @HbSync + $ fromString @LBS8.ByteString + $ show k + + flip runContT pure $ callCC \exit -> do + fname <- liftIO $ Temp.writeTempFile "." "fixme-issue" txt + + h1 <- liftIO $ try @_ @SomeException (LBS.readFile fname) + <&> fromRight mempty + <&> hashObject @HbSync + + ContT $ bracket none (const $ rm fname) + + void $ runProcess $ shell [qc|{editor} {fname}|] + + s <- liftIO $ LBS.readFile fname + + h2 <- liftIO $ try @_ @SomeException (LBS.readFile fname) + <&> fromRight mempty + <&> hashObject @HbSync + + fxs <- lift $ scanBlobOpts NoIndents Nothing s + + when (h1 == h2) $ exit () + + lift $ withState $ transactional do + for fxs $ \f -> do + key <- liftIO $ UUID.nextRandom <&> show + let norm = f & set (field @"fixmeStart") mzero + & set (field @"fixmeEnd") mzero + & setKey key + & set (field @"fixmeTs") (Just $ fromIntegral now) + & fixmeDerivedFields + + notice $ "fixme" <+> pretty (fixmeKey norm) + insertFixme norm + + import_ :: FixmePerks m => FixmeM m () import_ = do fxs0 <- scanFiles diff --git a/fixme-new/lib/Fixme/Scan.hs b/fixme-new/lib/Fixme/Scan.hs index 686d8b0e..59d73983 100644 --- a/fixme-new/lib/Fixme/Scan.hs +++ b/fixme-new/lib/Fixme/Scan.hs @@ -1,5 +1,11 @@ {-# Language MultiWayIf #-} -module Fixme.Scan (scanBlob,scanMagic,updateScanMagic) where +module Fixme.Scan + ( scanBlobOpts + , scanBlob + , scanMagic + , updateScanMagic + , NoIndents(..) + ) where import Fixme.Prelude hiding (indent) import Fixme.Types @@ -74,12 +80,34 @@ updateScanMagic = do magic <- scanMagic atomically $ writeTVar t (Just magic) -scanBlob :: forall m . FixmePerks m - => Maybe FilePath -- ^ filename to detect type - -> ByteString -- ^ content +class IsScanBlobOptions a where + ignoreIndents :: a -> Bool + +data NoIndents = NoIndents + +instance IsScanBlobOptions () where + ignoreIndents = const False + +instance IsScanBlobOptions NoIndents where + ignoreIndents = const True + +scanBlob :: forall m . (FixmePerks m) + => Maybe FilePath + -> ByteString -> FixmeM m [Fixme] -scanBlob fpath lbs = do +scanBlob = scanBlobOpts () + + +scanBlobOpts :: forall o m . (IsScanBlobOptions o, FixmePerks m) + => o + -> Maybe FilePath + -> ByteString + -> FixmeM m [Fixme] + +scanBlobOpts o fpath lbs = do + + let indents = not (ignoreIndents o) tagz <- asks fixmeEnvTags >>= readTVarIO @@ -120,7 +148,7 @@ scanBlob fpath lbs = do if | eln > 1 -> next (S S0 (x:xs)) - | li <= l0 && not (LBS8.null bs) -> next (S S0 (x:xs)) + | indents && li <= l0 && not (LBS8.null bs) -> next (S S0 (x:xs)) | otherwise -> do diff --git a/flake.lock b/flake.lock deleted file mode 100644 index 3034d52e..00000000 --- a/flake.lock +++ /dev/null @@ -1,219 +0,0 @@ -{ - "nodes": { - "db-pipe": { - "inputs": { - "haskell-flake-utils": [ - "haskell-flake-utils" - ], - "nixpkgs": [ - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1, - "narHash": "sha256-/HVVyxa55pDLzMiRgCWB4YKVsW2v9wFHTlSpLnyuhkU=", - "path": "./miscellaneous/db-pipe", - "type": "path" - }, - "original": { - "path": "./miscellaneous/db-pipe", - "type": "path" - } - }, - "flake-utils": { - "inputs": { - "systems": "systems" - }, - "locked": { - "lastModified": 1726560853, - "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "fuzzy": { - "inputs": { - "haskell-flake-utils": [ - "haskell-flake-utils" - ], - "nixpkgs": [ - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1, - "narHash": "sha256-BF9Xd2fa8L5Xju9NTaoUjmzUEJfrRMMKULYQieBjbKo=", - "path": "./miscellaneous/fuzzy-parse", - "type": "path" - }, - "original": { - "path": "./miscellaneous/fuzzy-parse", - "type": "path" - } - }, - "haskell-flake-utils": { - "inputs": { - "flake-utils": [ - "flake-utils" - ] - }, - "locked": { - "lastModified": 1707809372, - "narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=", - "owner": "ivanovs-4", - "repo": "haskell-flake-utils", - "rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2", - "type": "github" - }, - "original": { - "owner": "ivanovs-4", - "ref": "master", - "repo": "haskell-flake-utils", - "type": "github" - } - }, - "hspup": { - "inputs": { - "haskell-flake-utils": [ - "haskell-flake-utils" - ], - "nixpkgs": [ - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1679933705, - "narHash": "sha256-UOd70L+FKQLmGjA3IqjFaBpaS/dZMSABtRgVDY3lBCg=", - "owner": "voidlizard", - "repo": "hspup", - "rev": "6b969a9de1f9800ebfc61c51252b8647123c51bb", - "type": "github" - }, - "original": { - "owner": "voidlizard", - "repo": "hspup", - "type": "github" - } - }, - "libsodium": { - "inputs": { - "nixpkgs": "nixpkgs" - }, - "locked": { - "lastModified": 1, - "narHash": "sha256-lpDKsdOtVA2uudufrZM2yOKyeDZjWi/8O6kJnzq45H0=", - "path": "./miscellaneous/libsodium", - "type": "path" - }, - "original": { - "path": "./miscellaneous/libsodium", - "type": "path" - } - }, - "nixpkgs": { - "locked": { - "lastModified": 1728093190, - "narHash": "sha256-CAZF2NRuHmqTtRTNAruWpHA43Gg2UvuCNEIzabP0l6M=", - "owner": "nixos", - "repo": "nixpkgs", - "rev": "e2f08f4d8b3ecb5cf5c9fd9cb2d53bb3c71807da", - "type": "github" - }, - "original": { - "owner": "nixos", - "ref": "nixpkgs-unstable", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs_2": { - "locked": { - "lastModified": 1727089097, - "narHash": "sha256-ZMHMThPsthhUREwDebXw7GX45bJnBCVbfnH1g5iuSPc=", - "owner": "nixos", - "repo": "nixpkgs", - "rev": "568bfef547c14ca438c56a0bece08b8bb2b71a9c", - "type": "github" - }, - "original": { - "owner": "nixos", - "ref": "nixpkgs-unstable", - "repo": "nixpkgs", - "type": "github" - } - }, - "root": { - "inputs": { - "db-pipe": "db-pipe", - "flake-utils": "flake-utils", - "fuzzy": "fuzzy", - "haskell-flake-utils": "haskell-flake-utils", - "hspup": "hspup", - "libsodium": "libsodium", - "nixpkgs": "nixpkgs_2", - "saltine": "saltine", - "suckless-conf": "suckless-conf" - } - }, - "saltine": { - "flake": false, - "locked": { - "lastModified": 1, - "narHash": "sha256-xiHTxEXKTwS4Q35/LZi4TYCkzvoXtX7AjWsUcWT6yo0=", - "path": "./miscellaneous/saltine", - "type": "path" - }, - "original": { - "path": "./miscellaneous/saltine", - "type": "path" - } - }, - "suckless-conf": { - "inputs": { - "fuzzy": [ - "fuzzy" - ], - "haskell-flake-utils": [ - "haskell-flake-utils" - ], - "nixpkgs": [ - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1, - "narHash": "sha256-esabG5zoApNLbirx0mCj1+3ZPFU9Ckod9wSn9MHc0mo=", - "path": "./miscellaneous/suckless-conf", - "type": "path" - }, - "original": { - "path": "./miscellaneous/suckless-conf", - "type": "path" - } - }, - "systems": { - "locked": { - "lastModified": 1681028828, - "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", - "owner": "nix-systems", - "repo": "default", - "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", - "type": "github" - }, - "original": { - "owner": "nix-systems", - "repo": "default", - "type": "github" - } - } - }, - "root": "root", - "version": 7 -} diff --git a/flake.nix b/flake.nix index 48467ef2..8f9a098d 100644 --- a/flake.nix +++ b/flake.nix @@ -179,3 +179,4 @@ outputs = { self, nixpkgs, flake-utils, ... }@inputs: ); } + diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs index cb6f83a5..cd368a88 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs @@ -632,6 +632,13 @@ run d sy = do tvd <- newTVarIO d lastDef nil <$> runReaderT (fromRunM (mapM eval sy)) tvd +runEval :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + ) => TVar (Dict c m) -> [Syntax c] -> m (Syntax c) +runEval tvd sy = do + lastDef nil <$> runReaderT (fromRunM (mapM eval sy)) tvd + evalTop :: forall c m . ( IsContext c , MonadUnliftIO m , Exception (BadFormException c)) @@ -647,6 +654,15 @@ bindMatch n fn = HM.singleton n (Bind man (BindLambda fn)) bindValue :: Id -> Syntax c -> Dict c m bindValue n e = HM.singleton n (Bind mzero (BindValue e)) +lookupValue :: forall c m . (IsContext c, MonadUnliftIO m) + => Id -> RunM c m (Syntax c) +lookupValue i = do + ask >>= readTVarIO + <&> (fmap bindAction . HM.lookup i) + <&> \case + Just (BindValue s) -> s + _ -> nil + nil :: forall c . IsContext c => Syntax c nil = List noContext []