wip, fixme-new cat works

.fixme-new/config

@@ -17,7 +17,7 @@ fixme-attribs resolution cat scope
 
 fixme-value-set workflow new backlog wip test fixed done
 
-fixme-value-set cat bug feat refactor
+; fixme-value-set cat bug feat refactor
 
 fixme-value-set scope mvp-0 mvp-1 backlog
 

fixme-new/examples/config

@@ -0,0 +1,54 @@
+
+; fixme-files **/*.hs docs/devlog.md
+
+; no-debug
+; debug
+
+fixme-prefix     FIXME:
+fixme-prefix     TODO:
+fixme-prefix     PR:
+fixme-prefix     REVIEW:
+
+fixme-git-scan-filter-days 30
+
+fixme-attribs assigned workflow type
+
+fixme-attribs resolution cat scope
+
+fixme-value-set workflow new backlog wip test fixed done
+
+; fixme-value-set cat bug feat refactor
+
+fixme-value-set scope mvp-0 mvp-1 backlog
+
+fixme-files **/*.txt docs/devlog.md
+fixme-files **/*.hs
+
+fixme-file-comments "*.scm" ";"
+
+fixme-comments ";" "--"
+
+(define-template short
+  (quot
+    (simple
+         (trim 10  $fixme-key) " "
+
+         (if (~ FIXME $fixme-tag)
+          (then (fgd red (align 6  $fixme-tag))  )
+          (else (if (~ TODO $fixme-tag)
+                  (then (fgd green (align 6  $fixme-tag)))
+                  (else (align 6  $fixme-tag)) ) )
+          )
+
+
+         (align 10  ("[" $workflow "]"))  " "
+         (align 8  $type)  " "
+         (align 12 $assigned)  " "
+         (align 20 (trim 20 $committer-name)) " "
+         (trim 50  ($fixme-title)) " "
+         (nl))
+    )
+)
+
+(set-template default short)
+

fixme-new/examples/config-fixme-new-config

@@ -0,0 +1,6 @@
+
+fixme-pager (quot (bat  "--file-name" $file "-H" $before))
+
+fixme-def-context 2 5
+
+

fixme-new/lib/Fixme/Run.hs

@@ -195,7 +195,25 @@ runTop forms = do
          _ -> throwIO $ BadFormException @C nil
 
        entry $ bindMatch "fixme-pager" $ nil_ \case
-        _ -> warn $ yellow "fixme-pager" <+> "instruction is not supported yet"
+         [ListVal cmd0] -> do
+            t <- lift $ 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
 
        entry $ bindMatch "fixme-def-context" $ nil_ \case
         [LitIntVal a, LitIntVal b] -> do
@@ -204,6 +222,15 @@ runTop forms = do
 
         _ -> throwIO $ BadFormException @C nil
 
+       entry $ bindMatch "cat" $ nil_ \case
+        [SymbolVal "metadata", FixmeHashLike hash] -> do
+          lift $ catFixmeMetadata hash
+
+        [FixmeHashLike hash] -> do
+          lift $ catFixme hash
+
+        _ -> throwIO $ BadFormException @C nil
+
        entry $ bindMatch "report" $ nil_ \case
         [] -> lift $ list_ Nothing ()
 

fixme-new/lib/Fixme/Run/Internal.hs

@@ -234,3 +234,60 @@ list_ tpl a = do
 
         liftIO $ hPutDoc stdout what
 
+catFixmeMetadata :: FixmePerks m => Text -> FixmeM m ()
+catFixmeMetadata = cat_ True
+
+catFixme :: FixmePerks m => Text -> FixmeM m ()
+catFixme = cat_ False
+
+cat_ :: FixmePerks m => Bool -> Text -> FixmeM m ()
+cat_ metaOnly hash = do
+
+  (before,after)  <- asks fixmeEnvCatContext >>= readTVarIO
+  gd  <- fixmeGetGitDirCLIOpt
+
+  CatAction action <- asks fixmeEnvCatAction >>= readTVarIO
+
+  void $ flip runContT pure do
+    callCC \exit -> do
+
+      mha <- lift $ selectFixmeHash hash
+
+      ha <- ContT $ maybe1 mha (pure ())
+
+      fme' <- lift $ selectFixme ha
+
+      Fixme{..} <- ContT $ maybe1 fme' (pure ())
+
+      when metaOnly do
+        for_ (HM.toList fixmeAttr) $ \(k,v) -> do
+          liftIO $ print $ (pretty k <+> pretty v)
+        exit ()
+
+      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 = [ (mkId k, mkStr @C   v) | (k,v) <- HM.toList fixmeAttr ]
+                 <>
+                 [ (mkId (FixmeAttrName "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)
+