basic fixme editing

2024-10-07 05:23:16 +03:00 · 2024-10-07 05:23:16 +03:00 · 5324e83031
parent 04de089750
commit 5324e83031
8 changed files with 161 additions and 230 deletions
--- 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" ";"

--- a/fixme-new/fixme.cabal
+++ b/fixme-new/fixme.cabal
@ -100,6 +100,7 @@ common shared-properties
      , random
      , vector
      , unix
+      , uuid


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

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

--- a/flake.lock
+++ b/flake.lock
@ -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
-}
--- a/flake.nix
+++ b/flake.nix
@ -179,3 +179,4 @@ outputs = { self, nixpkgs, flake-utils, ... }@inputs:
 );

 }
+
--- 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 []