mirror of https://github.com/voidlizard/hbs2
571 lines
17 KiB
Haskell
571 lines
17 KiB
Haskell
{-# Language MultiWayIf #-}
|
|
{-# Language PatternSynonyms #-}
|
|
{-# Language ViewPatterns #-}
|
|
module Fixme.Run where
|
|
|
|
import Prelude hiding (init)
|
|
import Fixme.Prelude hiding (indent)
|
|
import Fixme.Types
|
|
import Fixme.Config
|
|
import Fixme.State
|
|
import Fixme.Scan.Git.Local as Git
|
|
import Fixme.Scan as Scan
|
|
|
|
import HBS2.Git.Local.CLI
|
|
|
|
import HBS2.System.Dir
|
|
import DBPipe.SQLite hiding (field)
|
|
import Data.Config.Suckless
|
|
|
|
import Data.Aeson.Encode.Pretty as Aeson
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
|
import Data.Either
|
|
import Data.Maybe
|
|
import Data.HashSet qualified as HS
|
|
import Data.HashMap.Strict (HashMap)
|
|
import Data.HashMap.Strict qualified as HM
|
|
import Data.Text qualified as Text
|
|
import Text.InterpolatedString.Perl6 (qc)
|
|
import Data.Coerce
|
|
import Control.Monad.Identity
|
|
import Lens.Micro.Platform
|
|
import System.Process.Typed
|
|
import Control.Monad.Trans.Cont
|
|
import Control.Monad.Trans.Maybe
|
|
|
|
import Streaming.Prelude qualified as S
|
|
|
|
{- HLINT ignore "Functor law" -}
|
|
|
|
pattern Init :: forall {c}. Syntax c
|
|
pattern Init <- ListVal [SymbolVal "init"]
|
|
|
|
pattern ScanGitLocal :: forall {c}. [ScanGitArgs] -> Syntax c
|
|
pattern ScanGitLocal e <- ListVal (SymbolVal "scan-git" : (scanGitArgs -> e))
|
|
|
|
pattern Update :: forall {c}. [ScanGitArgs] -> Syntax c
|
|
pattern Update e <- ListVal (SymbolVal "update" : (scanGitArgs -> e))
|
|
|
|
pattern ReadFixmeStdin :: forall {c}. Syntax c
|
|
pattern ReadFixmeStdin <- ListVal [SymbolVal "read-fixme-stdin"]
|
|
|
|
pattern FixmeFiles :: forall {c} . [FilePattern] -> Syntax c
|
|
pattern FixmeFiles e <- ListVal (SymbolVal "fixme-files" : (fileMasks -> e))
|
|
|
|
|
|
pattern FixmePrefix :: forall {c} . FixmeTag -> Syntax c
|
|
pattern FixmePrefix s <- ListVal [SymbolVal "fixme-prefix", fixmePrefix -> Just s]
|
|
|
|
pattern FixmeGitScanFilterDays :: forall {c}. Integer -> Syntax c
|
|
pattern FixmeGitScanFilterDays d <- ListVal [ SymbolVal "fixme-git-scan-filter-days", LitIntVal d ]
|
|
|
|
|
|
|
|
scanGitArgs :: [Syntax c] -> [ScanGitArgs]
|
|
scanGitArgs syn = [ w | ScanGitArgs w <- syn ]
|
|
|
|
|
|
fileMasks :: [Syntax c] -> [FilePattern]
|
|
fileMasks what = [ show (pretty s) | s <- what ]
|
|
|
|
fixmePrefix :: Syntax c -> Maybe FixmeTag
|
|
fixmePrefix = \case
|
|
SymbolVal s -> Just (FixmeTag (coerce s))
|
|
_ -> Nothing
|
|
|
|
|
|
defaultTemplate :: HashMap Id FixmeTemplate
|
|
defaultTemplate = HM.fromList [ ("default", Simple (SimpleTemplate short)) ]
|
|
where
|
|
short = parseTop s & fromRight mempty
|
|
s = [qc|
|
|
(trim 10 $fixme-key) " "
|
|
(align 6 $fixme-tag) " "
|
|
(trim 50 ($fixme-title))
|
|
(nl)
|
|
|]
|
|
|
|
|
|
runFixmeCLI :: FixmePerks m => FixmeM m a -> m a
|
|
runFixmeCLI m = do
|
|
db <- newDBPipeEnv dbPipeOptsDef =<< localDBPath
|
|
env <- FixmeEnv Nothing db
|
|
<$> newTVarIO mempty
|
|
<*> newTVarIO mempty
|
|
<*> newTVarIO mempty
|
|
<*> newTVarIO mempty
|
|
<*> newTVarIO mempty
|
|
<*> newTVarIO defCommentMap
|
|
<*> newTVarIO Nothing
|
|
<*> newTVarIO mempty
|
|
<*> newTVarIO mempty
|
|
<*> newTVarIO defaultCatAction
|
|
<*> newTVarIO defaultTemplate
|
|
<*> newTVarIO (1,3)
|
|
|
|
runReaderT ( setupLogger >> fromFixmeM (evolve >> m) ) env
|
|
`finally` flushLoggers
|
|
where
|
|
setupLogger = do
|
|
setLogging @ERROR $ toStderr . logPrefix "[error] "
|
|
setLogging @WARN $ toStderr . logPrefix "[warn] "
|
|
setLogging @NOTICE $ toStdout . logPrefix ""
|
|
pure ()
|
|
|
|
flushLoggers = do
|
|
silence
|
|
|
|
-- FIXME: tied-fucking-context
|
|
defaultCatAction = CatAction $ \dict lbs -> do
|
|
LBS.putStr lbs
|
|
pure ()
|
|
|
|
silence :: FixmePerks m => m ()
|
|
silence = do
|
|
setLoggingOff @DEBUG
|
|
setLoggingOff @ERROR
|
|
setLoggingOff @WARN
|
|
setLoggingOff @NOTICE
|
|
|
|
|
|
|
|
readConfig :: FixmePerks m => FixmeM m [Syntax C]
|
|
readConfig = do
|
|
|
|
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
|
|
lo <- localConfigDir
|
|
|
|
let lo0 = takeFileName lo
|
|
|
|
mkdir lo
|
|
touch (lo </> "config")
|
|
|
|
let gitignore = lo </> ".gitignore"
|
|
here <- doesPathExist gitignore
|
|
|
|
unless here do
|
|
liftIO $ writeFile gitignore $ show $
|
|
vcat [ pretty ("." </> localDBName)
|
|
]
|
|
|
|
notice $ yellow "run" <> line <> vcat [
|
|
"git add" <+> pretty (lo0 </> ".gitignore")
|
|
, "git add" <+> pretty (lo0 </> "config")
|
|
]
|
|
|
|
|
|
|
|
readFixmeStdin :: FixmePerks m => FixmeM m ()
|
|
readFixmeStdin = do
|
|
what <- liftIO LBS8.getContents
|
|
fixmies <- Scan.scanBlob Nothing what
|
|
liftIO $ print $ vcat (fmap pretty fixmies)
|
|
|
|
|
|
list_ :: (FixmePerks m, HasPredicate a) => Maybe Id -> a -> FixmeM m ()
|
|
list_ tpl a = do
|
|
tpl <- asks fixmeEnvTemplates >>= readTVarIO
|
|
<&> HM.lookup (fromMaybe "default" tpl)
|
|
|
|
fixmies <- selectFixmeThin a
|
|
|
|
case tpl of
|
|
Nothing-> do
|
|
liftIO $ LBS.putStr $ Aeson.encodePretty fixmies
|
|
|
|
Just (Simple (SimpleTemplate simple)) -> do
|
|
for_ fixmies $ \(FixmeThin attr) -> do
|
|
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
|
|
|
|
|
|
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 = [ (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
|
|
acts <- asks fixmeEnvUpdateActions >>= readTVarIO
|
|
|
|
void $ runMaybeT do
|
|
|
|
ha <- toMPlus =<< lift (selectFixmeHash txt)
|
|
let syn = mkLit @Text [qc|deleted "{pretty ha}"|]
|
|
|
|
debug $ red "deleted" <+> pretty ha
|
|
|
|
for_ acts $ \(UpdateAction what) -> do
|
|
liftIO $ what (Literal noContext syn)
|
|
|
|
|
|
modify_ :: FixmePerks m => Text -> String -> String -> FixmeM m ()
|
|
modify_ txt a b = do
|
|
acts <- asks fixmeEnvUpdateActions >>= readTVarIO
|
|
|
|
ts <- getEpoch
|
|
|
|
void $ runMaybeT do
|
|
|
|
ha <- toMPlus =<< lift (selectFixmeHash txt)
|
|
let syn = mkLit @Text [qc|modified {ts} "{pretty ha}" "{a}" "{b}"|]
|
|
|
|
debug $ red $ pretty syn
|
|
|
|
for_ acts $ \(UpdateAction what) -> do
|
|
liftIO $ what (Literal noContext syn)
|
|
|
|
|
|
|
|
printEnv :: FixmePerks m => FixmeM m ()
|
|
printEnv = do
|
|
g <- asks fixmeEnvGitDir
|
|
masks <- asks fixmeEnvFileMask >>= readTVarIO
|
|
tags <- asks fixmeEnvTags >>= readTVarIO
|
|
days <- asks fixmeEnvGitScanDays >>= readTVarIO
|
|
comments1 <- asks fixmeEnvDefComments >>= readTVarIO <&> HS.toList
|
|
|
|
comments2 <- asks fixmeEnvFileComments >>= readTVarIO
|
|
<&> HM.toList
|
|
<&> fmap (over _2 HS.toList)
|
|
|
|
attr <- asks fixmeEnvAttribs >>= readTVarIO <&> HS.toList
|
|
vals <- asks fixmeEnvAttribValues >>= readTVarIO <&> HM.toList
|
|
|
|
for_ tags $ \m -> do
|
|
liftIO $ print $ "fixme-prefix" <+> pretty m
|
|
|
|
for_ masks $ \m -> do
|
|
liftIO $ print $ "fixme-files" <+> dquotes (pretty m)
|
|
|
|
for_ days $ \d -> do
|
|
liftIO $ print $ "fixme-git-scan-filter-days" <+> pretty d
|
|
|
|
for_ comments1 $ \d -> do
|
|
liftIO $ print $ "fixme-comments" <+> dquotes (pretty d)
|
|
|
|
for_ comments2 $ \(ft, comm') -> do
|
|
for_ comm' $ \comm -> do
|
|
liftIO $ print $ "fixme-file-comments"
|
|
<+> dquotes (pretty ft) <+> dquotes (pretty comm)
|
|
|
|
for_ attr $ \a -> do
|
|
liftIO $ print $ "fixme-attribs"
|
|
<+> pretty a
|
|
|
|
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"
|
|
|
|
|
|
splitForms :: [String] -> [[String]]
|
|
splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
|
|
where
|
|
go acc ( "then" : rest ) = emit acc >> go mempty rest
|
|
go acc ( "and" : rest ) = emit acc >> go mempty rest
|
|
go acc ( x : rest ) = go ( x : acc ) rest
|
|
go acc [] = emit acc
|
|
|
|
emit = S.yield . reverse
|
|
|
|
sanitizeLog :: [Syntax c] -> [Syntax c]
|
|
sanitizeLog lls = flip filter lls $ \case
|
|
ListVal (SymbolVal "deleted" : _) -> True
|
|
ListVal (SymbolVal "modified" : _) -> True
|
|
_ -> False
|
|
|
|
pattern Template :: forall {c}. Maybe Id -> [Syntax c] -> [Syntax c]
|
|
pattern Template w syn <- (mbTemplate -> (w, syn))
|
|
|
|
mbTemplate :: [Syntax c] -> (Maybe Id, [Syntax c])
|
|
mbTemplate = \case
|
|
( SymbolVal "template" : StringLike w : rest ) -> (Just (fromString w), rest)
|
|
other -> (Nothing, other)
|
|
|
|
pattern IsSimpleTemplate :: forall {c} . [Syntax c] -> [Syntax c]
|
|
pattern IsSimpleTemplate xs <- [ListVal (SymbolVal "simple" : xs)]
|
|
|
|
run :: FixmePerks m => [String] -> FixmeM m ()
|
|
run what = do
|
|
|
|
sc <- readConfig
|
|
|
|
let s0 = fmap (parseTop . unwords) (splitForms what)
|
|
& rights
|
|
& mconcat
|
|
|
|
runForms (sc <> s0)
|
|
|
|
where
|
|
|
|
runForms :: forall c m . (IsContext c, Data c, Data (Context c), FixmePerks m)
|
|
=> [Syntax c]
|
|
-> FixmeM m ()
|
|
runForms ss = for_ ss $ \s -> do
|
|
|
|
debug $ pretty s
|
|
|
|
case s of
|
|
|
|
FixmeFiles xs -> do
|
|
t <- asks fixmeEnvFileMask
|
|
atomically (modifyTVar t (<> xs))
|
|
|
|
FixmePrefix tag -> do
|
|
t <- asks fixmeEnvTags
|
|
atomically (modifyTVar t (HS.insert tag))
|
|
|
|
FixmeGitScanFilterDays d -> do
|
|
t <- asks fixmeEnvGitScanDays
|
|
atomically (writeTVar t (Just d))
|
|
|
|
ListVal [SymbolVal "fixme-file-comments", StringLike ft, StringLike b] -> do
|
|
let co = Text.pack b & HS.singleton
|
|
t <- asks fixmeEnvFileComments
|
|
atomically (modifyTVar t (HM.insertWith (<>) (commentKey ft) co))
|
|
|
|
ListVal (SymbolVal "fixme-comments" : StringLikeList xs) -> do
|
|
t <- asks fixmeEnvDefComments
|
|
let co = fmap Text.pack xs & HS.fromList
|
|
atomically $ modifyTVar t (<> co)
|
|
|
|
ListVal (SymbolVal "fixme-attribs" : StringLikeList xs) -> 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
|
|
let vals = fmap fromString xs & HS.fromList
|
|
atomically $ modifyTVar t (HM.insertWith (<>) name vals)
|
|
|
|
Init -> init
|
|
|
|
ScanGitLocal args -> scanGitLocal args Nothing
|
|
|
|
Update args -> scanGitLocal args Nothing
|
|
|
|
ListVal (SymbolVal "list" : (Template n [])) -> do
|
|
debug $ "list" <+> pretty n
|
|
list_ n ()
|
|
|
|
ListVal (SymbolVal "list" : (Template n whatever)) -> do
|
|
debug $ "list" <+> pretty n
|
|
list_ n whatever
|
|
|
|
|
|
ListVal [SymbolVal "cat", SymbolVal "metadata", FixmeHashLike hash] -> do
|
|
catFixmeMetadata hash
|
|
|
|
ListVal [SymbolVal "cat", FixmeHashLike hash] -> do
|
|
catFixme hash
|
|
|
|
ListVal [SymbolVal "delete", FixmeHashLike hash] -> do
|
|
delete hash
|
|
|
|
ListVal [SymbolVal "modify", FixmeHashLike hash, StringLike a, StringLike b] -> do
|
|
modify_ hash a b
|
|
|
|
ListVal [SymbolVal "modified", TimeStampLike t, FixmeHashLike hash, StringLike a, StringLike b] -> do
|
|
debug $ green $ pretty s
|
|
updateFixme (Just t) hash (fromString a) (fromString b)
|
|
|
|
ListVal [SymbolVal "modified", FixmeHashLike hash, StringLike a, StringLike b] -> do
|
|
debug $ green $ pretty s
|
|
updateFixme Nothing hash (fromString a) (fromString b)
|
|
|
|
ListVal [SymbolVal "deleted", FixmeHashLike hash] -> do
|
|
deleteFixme hash
|
|
|
|
ReadFixmeStdin -> readFixmeStdin
|
|
|
|
ListVal [SymbolVal "print-env"] -> do
|
|
printEnv
|
|
|
|
ListVal (SymbolVal "hello" : xs) -> do
|
|
notice $ "hello" <+> pretty xs
|
|
|
|
ListVal (SymbolVal "define-template" : SymbolVal who : IsSimpleTemplate xs) -> do
|
|
trace $ "define-template" <+> pretty who <+> "simple" <+> hsep (fmap pretty xs)
|
|
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
|
|
env <- ask
|
|
t <- asks fixmeEnvUpdateActions
|
|
let repl syn = [ ( "$1", syn ) ]
|
|
let action = UpdateAction @c $ \syn -> do
|
|
liftIO (withFixmeEnv env (runForms (inject (repl syn) xs)))
|
|
|
|
atomically $ modifyTVar t (<> [action])
|
|
|
|
ListVal (SymbolVal "fixme-play-log-action" : xs) -> do
|
|
debug $ "fixme-play-log-action" <+> pretty xs
|
|
env <- ask
|
|
t <- asks fixmeEnvReadLogActions
|
|
let action = ReadLogAction @c $ \_ -> liftIO (withFixmeEnv env (runForms xs))
|
|
atomically $ modifyTVar t (<> [action])
|
|
|
|
ListVal (SymbolVal "append-file" : StringLike fn : StringLikeList xs) -> do
|
|
debug "append-file"
|
|
liftIO $ for_ xs $ \x -> do
|
|
appendFile fn x
|
|
appendFile fn "\n"
|
|
|
|
ListVal [SymbolVal "play-log-file", StringLike fn] -> do
|
|
debug $ yellow "play-log-file" <+> pretty fn
|
|
-- FIXME: just-for-in-case-sanitize-input
|
|
-- $workflow: done
|
|
what <- try @_ @IOException (liftIO $ readFile fn)
|
|
<&> fromRight mempty
|
|
<&> parseTop
|
|
<&> fromRight mempty
|
|
<&> sanitizeLog
|
|
|
|
env <- ask
|
|
liftIO $ withFixmeEnv env (runForms what)
|
|
|
|
ListVal [SymbolVal "no-debug"] -> do
|
|
setLoggingOff @DEBUG
|
|
|
|
ListVal [SymbolVal "silence"] -> do
|
|
silence
|
|
|
|
ListVal [SymbolVal "builtin:evolve"] -> do
|
|
evolve
|
|
|
|
ListVal [SymbolVal "builtin:cleanup-state"] -> do
|
|
cleanupDatabase
|
|
|
|
ListVal [SymbolVal "builtin:update-indexes"] -> do
|
|
updateIndexes
|
|
|
|
|
|
ListVal [SymbolVal "builtin:select-fixme-hash", FixmeHashLike x] -> do
|
|
w <- selectFixmeHash x
|
|
liftIO $ print $ pretty w
|
|
|
|
ListVal [SymbolVal "trace"] -> do
|
|
setLogging @TRACE (logPrefix "[trace] " . toStderr)
|
|
trace "trace on"
|
|
|
|
ListVal [SymbolVal "no-trace"] -> do
|
|
trace "trace off"
|
|
setLoggingOff @TRACE
|
|
|
|
ListVal [SymbolVal "debug"] -> do
|
|
setLogging @DEBUG $ toStderr . logPrefix "[debug] "
|
|
|
|
w -> err (pretty w)
|
|
|
|
|