diff --git a/.fixme-new/config b/.fixme-new/config index da5db46d..eb48d693 100644 --- a/.fixme-new/config +++ b/.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 diff --git a/fixme-new/examples/config b/fixme-new/examples/config new file mode 100644 index 00000000..eb48d693 --- /dev/null +++ b/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) + diff --git a/fixme-new/examples/config-fixme-new-config b/fixme-new/examples/config-fixme-new-config new file mode 100644 index 00000000..d144b83d --- /dev/null +++ b/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 + + diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 43e19483..d9a0b2ea 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/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 () diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index 97cd2961..c1038e56 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/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) +