mirror of https://github.com/voidlizard/hbs2
wip, re-implementing fixme-new
This commit is contained in:
Dmitry Zuikov
parent
7e2dd9ba56
commit
440ad2b415
|
|
@ -1,6 +1,7 @@
|
|||
module Main where
|
||||
|
||||
import Fixme
|
||||
-- import Fixme.Run
|
||||
import Fixme.Run
|
||||
import System.Environment
|
||||
|
||||
|
|
@ -62,7 +63,7 @@ main = do
|
|||
-- TODO: scan-all-sources
|
||||
-- for-source-from-con
|
||||
|
||||
runFixmeCLI (run =<< liftIO getArgs)
|
||||
runFixmeCLI (runTop =<< liftIO getArgs)
|
||||
|
||||
-- FIXME: test-fixme
|
||||
-- $workflow: wip
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ module Fixme.Prelude
|
|||
, GitRef(..)
|
||||
, Serialise(..)
|
||||
, serialise, deserialiseOrFail, deserialise
|
||||
, module Exported
|
||||
) where
|
||||
|
||||
import HBS2.Prelude.Plated as All
|
||||
|
|
@ -18,3 +19,6 @@ import Data.Function as All
|
|||
import UnliftIO as All
|
||||
import System.FilePattern as All
|
||||
import Control.Monad.Reader as All
|
||||
|
||||
import Data.Config.Suckless.Script as Exported
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,3 @@
|
|||
{-# Language MultiWayIf #-}
|
||||
{-# Language PatternSynonyms #-}
|
||||
{-# Language ViewPatterns #-}
|
||||
module Fixme.Run where
|
||||
|
||||
import Prelude hiding (init)
|
||||
|
|
@ -49,61 +46,6 @@ import System.IO.Temp as Temp
|
|||
import System.IO qualified as IO
|
||||
|
||||
|
||||
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 ]
|
||||
|
||||
|
||||
logRootKey :: SomeRefKey ByteString
|
||||
logRootKey = SomeRefKey "ROOT"
|
||||
|
||||
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
|
||||
|
|
@ -158,6 +100,17 @@ silence = do
|
|||
setLoggingOff @NOTICE
|
||||
|
||||
|
||||
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)
|
||||
|]
|
||||
|
||||
|
||||
readConfig :: FixmePerks m => FixmeM m [Syntax C]
|
||||
readConfig = do
|
||||
|
|
@ -197,631 +150,44 @@ init = do
|
|||
]
|
||||
|
||||
|
||||
runTop :: FixmePerks m => [String] -> FixmeM m ()
|
||||
runTop args = do
|
||||
|
||||
readFixmeStdin :: FixmePerks m => FixmeM m ()
|
||||
readFixmeStdin = do
|
||||
what <- liftIO LBS8.getContents
|
||||
fixmies <- Scan.scanBlob Nothing what
|
||||
liftIO $ print $ vcat (fmap pretty fixmies)
|
||||
forms <- parseTop (unlines $ unwords <$> splitForms args)
|
||||
& either (error.show) pure
|
||||
|
||||
-- pure ((unlines . fmap unwords . splitForms) what)
|
||||
-- >>= either (error.show) pure . parseTop
|
||||
|
||||
list_ :: (FixmePerks m, HasPredicate a) => Maybe Id -> a -> FixmeM m ()
|
||||
list_ tpl a = do
|
||||
tpl <- asks fixmeEnvTemplates >>= readTVarIO
|
||||
<&> HM.lookup (fromMaybe "default" tpl)
|
||||
let dict = makeDict @C do
|
||||
|
||||
fixmies <- selectFixmeThin a
|
||||
-- internalEntries
|
||||
|
||||
case tpl of
|
||||
Nothing-> do
|
||||
liftIO $ LBS.putStr $ Aeson.encodePretty fixmies
|
||||
entry $ bindMatch "--help" $ nil_ \case
|
||||
HelpEntryBound what -> helpEntry what
|
||||
[StringLike s] -> helpList False (Just s)
|
||||
_ -> helpList False Nothing
|
||||
|
||||
Just (Simple (SimpleTemplate simple)) -> do
|
||||
for_ fixmies $ \(FixmeThin attr) -> do
|
||||
let subst = [ (mkId k, mkstr @C v) | (k,v) <- HM.toList attr ]
|
||||
let what = render (SimpleTemplate (inject subst simple))
|
||||
& fromRight "render error"
|
||||
conf <- readConfig
|
||||
|
||||
liftIO $ hPutDoc stdout what
|
||||
run dict (conf <> forms) >>= eatNil display
|
||||
|
||||
-- notice $ red "re-implementing fixme-new"
|
||||
-- read refchan
|
||||
-- execute settings from refchan
|
||||
-- read config
|
||||
|
||||
catFixmeMetadata :: FixmePerks m => Text -> FixmeM m ()
|
||||
catFixmeMetadata = cat_ True
|
||||
|
||||
catFixme :: FixmePerks m => Text -> FixmeM m ()
|
||||
catFixme = cat_ False
|
||||
-- execute config
|
||||
-- execute cli
|
||||
pure ()
|
||||
-- sc <- readConfig
|
||||
|
||||
cat_ :: FixmePerks m => Bool -> Text -> FixmeM m ()
|
||||
cat_ metaOnly hash = do
|
||||
-- let s0 = fmap (parseTop . unwords) (splitForms what)
|
||||
-- & rights
|
||||
-- & mconcat
|
||||
|
||||
(before,after) <- asks fixmeEnvCatContext >>= readTVarIO
|
||||
gd <- fixmeGetGitDirCLIOpt
|
||||
-- runForms (sc <> s0)
|
||||
|
||||
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)
|
||||
|
||||
delete :: FixmePerks m => Text -> FixmeM m ()
|
||||
delete txt = do
|
||||
acts <- asks fixmeEnvUpdateActions >>= readTVarIO
|
||||
hashes <- selectFixmeHashes txt
|
||||
for_ hashes $ \ha -> do
|
||||
insertFixmeDelStaged ha
|
||||
|
||||
modify_ :: FixmePerks m => Text -> String -> String -> FixmeM m ()
|
||||
modify_ txt a b = do
|
||||
acts <- asks fixmeEnvUpdateActions >>= readTVarIO
|
||||
void $ runMaybeT do
|
||||
ha <- toMPlus =<< lift (selectFixmeHash txt)
|
||||
lift $ insertFixmeModStaged ha (fromString a) (fromString b)
|
||||
|
||||
exportToLog :: FixmePerks m => FilePath -> FixmeM m ()
|
||||
exportToLog fn = do
|
||||
e <- getEpoch
|
||||
warn $ red "EXPORT-FIXMIES" <+> pretty fn
|
||||
sto <- compactStorageOpen @HbSync mempty fn
|
||||
fx <- selectFixmeThin ()
|
||||
for_ fx $ \(FixmeThin m) -> void $ runMaybeT do
|
||||
h <- HM.lookup "fixme-hash" m & toMPlus
|
||||
loaded <- lift (selectFixme (coerce h)) >>= toMPlus
|
||||
let what = Added e loaded
|
||||
let k = mkKey what
|
||||
get sto k >>= guard . isNothing
|
||||
put sto (mkKey what) (LBS.toStrict $ serialise what)
|
||||
warn $ red "export" <+> pretty h
|
||||
|
||||
what <- selectStage
|
||||
|
||||
for_ what $ \w -> do
|
||||
let k = mkKey w
|
||||
v0 <- get sto k <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict)
|
||||
case v0 of
|
||||
Nothing -> do
|
||||
put sto k (LBS.toStrict $ serialise w)
|
||||
|
||||
Just (Left{}) -> do
|
||||
put sto k (LBS.toStrict $ serialise w)
|
||||
|
||||
Just (Right prev) | getSequence w > getSequence prev -> do
|
||||
put sto k (LBS.toStrict $ serialise w)
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
compactStorageClose sto
|
||||
|
||||
cleanStage
|
||||
|
||||
importFromLog :: FixmePerks m => CompactStorage HbSync -> FixmeM m ()
|
||||
importFromLog sto = do
|
||||
fset <- listAllFixmeHashes
|
||||
|
||||
-- sto <- compactStorageOpen @HbSync readonly fn
|
||||
ks <- keys sto
|
||||
|
||||
toImport <- S.toList_ do
|
||||
for_ ks $ \k -> runMaybeT do
|
||||
v <- get sto k & MaybeT
|
||||
what <- deserialiseOrFail @CompactAction (LBS.fromStrict v) & toMPlus
|
||||
|
||||
case what of
|
||||
Added _ fx -> do
|
||||
let ha = hashObject @HbSync (serialise fx) & HashRef
|
||||
unless (HS.member ha fset) do
|
||||
warn $ red "import" <+> viaShow (pretty ha)
|
||||
lift $ S.yield (Right fx)
|
||||
w -> lift $ S.yield (Left $ fromRight mempty $ parseTop (show $ pretty w))
|
||||
|
||||
withState $ transactional do
|
||||
for_ (rights toImport) insertFixme
|
||||
|
||||
let w = lefts toImport
|
||||
runForms (mconcat w)
|
||||
|
||||
unless (List.null toImport) do
|
||||
updateIndexes
|
||||
|
||||
-- compactStorageClose sto
|
||||
|
||||
printEnv :: FixmePerks m => FixmeM m ()
|
||||
printEnv = do
|
||||
g <- asks fixmeEnvGitDir >>= readTVarIO
|
||||
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))
|
||||
|
||||
for_ g $ \git -> do
|
||||
liftIO $ print $ "fixme-git-dir" <+> dquotes (pretty git)
|
||||
|
||||
dbPath <- asks fixmeEnvDbPath >>= readTVarIO
|
||||
liftIO $ print $ "fixme-state-path" <+> dquotes (pretty dbPath)
|
||||
|
||||
(before,after) <- asks fixmeEnvCatContext >>= readTVarIO
|
||||
|
||||
liftIO $ print $ "fixme-def-context" <+> pretty before <+> pretty after
|
||||
|
||||
ma <- asks fixmeEnvMacro >>= readTVarIO <&> HM.toList
|
||||
|
||||
for_ ma $ \(n, syn) -> do
|
||||
liftIO $ print $ parens ("define-macro" <+> pretty n <+> pretty syn)
|
||||
|
||||
|
||||
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)
|
||||
|
||||
|
||||
runForms :: forall c m . (IsContext c, Data c, Data (Context c), FixmePerks m)
|
||||
=> [Syntax c]
|
||||
-> FixmeM m ()
|
||||
runForms ss = for_ ss $ \s -> do
|
||||
|
||||
macros <- asks fixmeEnvMacro >>= readTVarIO
|
||||
|
||||
debug $ pretty s
|
||||
|
||||
case s of
|
||||
|
||||
(ListVal (SymbolVal name : rest)) | HM.member name macros -> do
|
||||
let repl = [ (mkId ("$",i), syn) | (i,syn) <- zip [1..] rest ]
|
||||
maybe1 (inject repl (HM.lookup name macros)) none $ \macro -> do
|
||||
debug $ yellow "run macro" <+> pretty macro
|
||||
runForms [macro]
|
||||
|
||||
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-git-dir", StringLike g] -> do
|
||||
ta <- asks fixmeEnvGitDir
|
||||
atomically $ writeTVar ta (Just g)
|
||||
|
||||
ListVal [SymbolVal "fixme-state-path", StringLike g] -> do
|
||||
p <- asks fixmeEnvDbPath
|
||||
db <- asks fixmeEnvDb
|
||||
atomically do
|
||||
writeTVar p g
|
||||
writeTVar db Nothing
|
||||
|
||||
evolve
|
||||
|
||||
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", TimeStampLike _, FixmeHashLike hash] -> do
|
||||
deleteFixme hash
|
||||
|
||||
ListVal [SymbolVal "deleted", FixmeHashLike hash] -> do
|
||||
deleteFixme hash
|
||||
|
||||
ListVal [SymbolVal "added", FixmeHashLike _] -> do
|
||||
-- we don't add fixmies at this stage
|
||||
-- but in fixme-import
|
||||
none
|
||||
|
||||
ReadFixmeStdin -> readFixmeStdin
|
||||
|
||||
ListVal [SymbolVal "print-env"] -> printEnv
|
||||
|
||||
ListVal (SymbolVal "hello" : xs) -> do
|
||||
notice $ "hello" <+> pretty xs
|
||||
|
||||
ListVal [SymbolVal "define-macro", SymbolVal name, macro@(ListVal{})] -> do
|
||||
debug $ yellow "define-macro" <+> pretty name <+> pretty macro
|
||||
macros <- asks fixmeEnvMacro
|
||||
atomically $ modifyTVar macros (HM.insert name (fixContext macro))
|
||||
|
||||
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 "update-action" : xs) -> do
|
||||
debug $ "update-action" <+> pretty xs
|
||||
env <- ask
|
||||
t <- asks fixmeEnvReadLogActions
|
||||
let action = ReadLogAction @c $ \_ -> liftIO (withFixmeEnv env (runForms xs))
|
||||
atomically $ modifyTVar t (<> [action])
|
||||
|
||||
ListVal [SymbolVal "import-git-logs", StringLike fn] -> do
|
||||
warn $ red "import-git-logs" <+> pretty fn
|
||||
scanGitLogLocal fn importFromLog
|
||||
|
||||
ListVal [SymbolVal "import", StringLike fn] -> do
|
||||
warn $ red "IMPORT" <+> pretty fn
|
||||
sto <- compactStorageOpen readonly fn
|
||||
importFromLog sto
|
||||
compactStorageClose sto
|
||||
|
||||
ListVal [SymbolVal "export", StringLike fn] -> do
|
||||
warn $ red "EXPORT" <+> pretty fn
|
||||
exportToLog fn
|
||||
|
||||
ListVal [SymbolVal "git:list-refs"] -> do
|
||||
refs <- listRefs False
|
||||
for_ refs $ \(h,r) -> do
|
||||
liftIO $ print $ pretty h <+> pretty r
|
||||
|
||||
ListVal [SymbolVal "git:merge-binary-log",StringLike o, StringLike target, StringLike b] -> do
|
||||
debug $ red "git:merge-binary-log" <+> pretty o <+> pretty target <+> pretty b
|
||||
|
||||
temp <- liftIO $ emptyTempFile "." "merge-result"
|
||||
sa <- compactStorageOpen @HbSync readonly o
|
||||
sb <- compactStorageOpen @HbSync readonly b
|
||||
r <- compactStorageOpen @HbSync mempty temp
|
||||
|
||||
for_ [sa,sb] $ \sto -> do
|
||||
ks <- keys sto
|
||||
for_ ks $ \k -> runMaybeT do
|
||||
v <- get sto k & MaybeT
|
||||
put r k v
|
||||
|
||||
compactStorageClose r
|
||||
compactStorageClose sa
|
||||
compactStorageClose sb
|
||||
|
||||
mv temp target
|
||||
|
||||
ListVal [SymbolVal "no-debug"] -> do
|
||||
setLoggingOff @DEBUG
|
||||
|
||||
ListVal [SymbolVal "silence"] -> do
|
||||
silence
|
||||
|
||||
ListVal [SymbolVal "builtin:run-stdin"] -> do
|
||||
let ini = mempty :: [Text]
|
||||
flip fix ini $ \next acc -> do
|
||||
eof <- liftIO IO.isEOF
|
||||
s <- if eof then pure "" else liftIO Text.getLine <&> Text.strip
|
||||
if Text.null s then do
|
||||
let code = parseTop (Text.unlines acc) & fromRight mempty
|
||||
runForms code
|
||||
unless eof do
|
||||
next mempty
|
||||
else do
|
||||
next (acc <> [s])
|
||||
|
||||
ListVal [SymbolVal "builtin:evolve"] -> do
|
||||
evolve
|
||||
|
||||
ListVal [SymbolVal "builtin:list-commits"] -> do
|
||||
co <- listCommits
|
||||
liftIO $ print $ vcat (fmap (pretty . view _1) co)
|
||||
|
||||
ListVal [SymbolVal "builtin:cleanup-state"] -> do
|
||||
cleanupDatabase
|
||||
|
||||
ListVal [SymbolVal "builtin:clean-stage"] -> do
|
||||
cleanStage
|
||||
|
||||
ListVal [SymbolVal "builtin:drop-stage"] -> do
|
||||
cleanStage
|
||||
|
||||
ListVal [SymbolVal "builtin:show-stage"] -> do
|
||||
stage <- selectStage
|
||||
liftIO $ print $ vcat (fmap pretty stage)
|
||||
|
||||
ListVal [SymbolVal "builtin:show-log", StringLike fn] -> do
|
||||
sto <- compactStorageOpen @HbSync readonly fn
|
||||
|
||||
ks <- keys sto
|
||||
|
||||
entries <- mapM (get sto) ks
|
||||
<&> catMaybes
|
||||
<&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict)
|
||||
<&> rights
|
||||
|
||||
liftIO $ print $ vcat (fmap pretty entries)
|
||||
|
||||
compactStorageClose sto
|
||||
|
||||
ListVal [SymbolVal "builtin:update-indexes"] -> do
|
||||
updateIndexes
|
||||
|
||||
ListVal [SymbolVal "builtin:scan-magic"] -> do
|
||||
magic <- scanMagic
|
||||
liftIO $ print $ pretty magic
|
||||
|
||||
ListVal [SymbolVal "builtin:select-fixme-hash", FixmeHashLike x] -> do
|
||||
w <- selectFixmeHash x
|
||||
liftIO $ print $ pretty w
|
||||
|
||||
ListVal [SymbolVal "builtin:git:list-stage"] -> do
|
||||
stage <- gitListStage
|
||||
for_ stage $ \case
|
||||
Left (fn,h) -> liftIO $ print $ "N" <+> pretty h <+> pretty fn
|
||||
Right (fn,h) -> liftIO $ print $ "E" <+> pretty h <+> pretty fn
|
||||
|
||||
ListVal (SymbolVal "builtin:git:extract-file-meta-data" : StringLikeList fs) -> do
|
||||
fxm <- gitExtractFileMetaData fs <&> HM.toList
|
||||
liftIO $ print $ vcat (fmap (pretty.snd) fxm)
|
||||
|
||||
ListVal (SymbolVal "builtin:git:extract-from-stage" : opts) -> do
|
||||
env <- ask
|
||||
gitStage <- gitListStage
|
||||
|
||||
let dry = or [ True | StringLike "dry" <- opts ]
|
||||
let verbose = or [ True | StringLike "verbose" <- opts ]
|
||||
|
||||
blobs <- for gitStage $ \case
|
||||
Left (fn, hash) -> pure (fn, hash, liftIO $ LBS8.readFile fn)
|
||||
Right (fn,hash) -> pure (fn, hash, liftIO (withFixmeEnv env $ gitCatBlob hash))
|
||||
|
||||
let fns = fmap (view _1) blobs
|
||||
|
||||
-- TODO: extract-metadata-from-git-blame
|
||||
-- subj
|
||||
|
||||
stageFile <- localConfigDir <&> (</> "current-stage.log")
|
||||
|
||||
fmeStage <- compactStorageOpen mempty stageFile
|
||||
|
||||
for_ blobs $ \(fn, bhash, readBlob) -> do
|
||||
nno <- newTVarIO (mempty :: HashMap FixmeTitle Integer)
|
||||
lbs <- readBlob
|
||||
fxs <- scanBlob (Just fn) lbs
|
||||
>>= \e -> do
|
||||
for e $ \fx0 -> do
|
||||
n <- atomically $ stateTVar nno (\m -> do
|
||||
let what = HM.lookup (fixmeTitle fx0) m & fromMaybe 0
|
||||
(what, HM.insert (fixmeTitle fx0) (succ what) m)
|
||||
)
|
||||
let ls = fixmePlain fx0
|
||||
meta <- getMetaDataFromGitBlame fn fx0
|
||||
let tit = fixmeTitle fx0 & coerce @_ @Text
|
||||
|
||||
-- FIXME: fix-this-copypaste
|
||||
let ks = [qc|{fn}#{tit}:{n}|] :: Text
|
||||
let ksh = hashObject @HbSync (serialise ks) & pretty & show & Text.pack & FixmeAttrVal
|
||||
let kh = HM.singleton "fixme-key" ksh
|
||||
let kv = HM.singleton "fixme-key-string" (FixmeAttrVal ks) <> kh
|
||||
|
||||
pure $ fixmeDerivedFields (fx0 <> mkFixmeFileName fn <> meta)
|
||||
& set (field @"fixmePlain") ls
|
||||
|
||||
& over (field @"fixmeAttr")
|
||||
(HM.insert "blob" (fromString $ show $ pretty bhash))
|
||||
& over (field @"fixmeAttr")
|
||||
(mappend (kh<>kv))
|
||||
|
||||
unless dry do
|
||||
for_ fxs $ \fx -> void $ runMaybeT do
|
||||
e <- getEpoch
|
||||
let what = Added e fx
|
||||
let k = mkKey (FromFixmeKey fx)
|
||||
get fmeStage k >>= guard . isNothing
|
||||
put fmeStage k (LBS.toStrict $ serialise what)
|
||||
|
||||
when verbose do
|
||||
liftIO $ print (pretty fx)
|
||||
|
||||
when dry do
|
||||
warn $ red "FUCKING DRY!"
|
||||
|
||||
compactStorageClose fmeStage
|
||||
|
||||
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)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,827 @@
|
|||
{-# 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 Fixme.Log
|
||||
|
||||
import HBS2.Git.Local.CLI
|
||||
|
||||
import HBS2.Base58
|
||||
import HBS2.Merkle
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Storage
|
||||
import HBS2.Storage.Compact
|
||||
import HBS2.System.Dir
|
||||
import DBPipe.SQLite hiding (field)
|
||||
import Data.Config.Suckless
|
||||
|
||||
import Data.Aeson.Encode.Pretty as Aeson
|
||||
import Data.ByteString (ByteString)
|
||||
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.HashSet (HashSet)
|
||||
import Data.Set qualified as Set
|
||||
import Data.Generics.Product.Fields (field)
|
||||
import Data.List qualified as List
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.IO 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 System.IO.Temp as Temp
|
||||
import System.IO qualified as IO
|
||||
|
||||
|
||||
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 ]
|
||||
|
||||
|
||||
logRootKey :: SomeRefKey ByteString
|
||||
logRootKey = SomeRefKey "ROOT"
|
||||
|
||||
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
|
||||
dbPath <- localDBPath
|
||||
git <- findGitDir
|
||||
env <- FixmeEnv
|
||||
<$> newMVar ()
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO dbPath
|
||||
<*> newTVarIO Nothing
|
||||
<*> newTVarIO git
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO defCommentMap
|
||||
<*> newTVarIO Nothing
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO defaultCatAction
|
||||
<*> newTVarIO defaultTemplate
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO (1,3)
|
||||
|
||||
-- FIXME: defer-evolve
|
||||
-- не все действия требуют БД,
|
||||
-- хорошо бы, что бы она не создавалась,
|
||||
-- если не требуется
|
||||
runReaderT ( setupLogger >> fromFixmeM (handle @_ @SomeException (err . viaShow) 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 = [ (mkId 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 = [ (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)
|
||||
|
||||
delete :: FixmePerks m => Text -> FixmeM m ()
|
||||
delete txt = do
|
||||
acts <- asks fixmeEnvUpdateActions >>= readTVarIO
|
||||
hashes <- selectFixmeHashes txt
|
||||
for_ hashes $ \ha -> do
|
||||
insertFixmeDelStaged ha
|
||||
|
||||
modify_ :: FixmePerks m => Text -> String -> String -> FixmeM m ()
|
||||
modify_ txt a b = do
|
||||
acts <- asks fixmeEnvUpdateActions >>= readTVarIO
|
||||
void $ runMaybeT do
|
||||
ha <- toMPlus =<< lift (selectFixmeHash txt)
|
||||
lift $ insertFixmeModStaged ha (fromString a) (fromString b)
|
||||
|
||||
exportToLog :: FixmePerks m => FilePath -> FixmeM m ()
|
||||
exportToLog fn = do
|
||||
e <- getEpoch
|
||||
warn $ red "EXPORT-FIXMIES" <+> pretty fn
|
||||
sto <- compactStorageOpen @HbSync mempty fn
|
||||
fx <- selectFixmeThin ()
|
||||
for_ fx $ \(FixmeThin m) -> void $ runMaybeT do
|
||||
h <- HM.lookup "fixme-hash" m & toMPlus
|
||||
loaded <- lift (selectFixme (coerce h)) >>= toMPlus
|
||||
let what = Added e loaded
|
||||
let k = mkKey what
|
||||
get sto k >>= guard . isNothing
|
||||
put sto (mkKey what) (LBS.toStrict $ serialise what)
|
||||
warn $ red "export" <+> pretty h
|
||||
|
||||
what <- selectStage
|
||||
|
||||
for_ what $ \w -> do
|
||||
let k = mkKey w
|
||||
v0 <- get sto k <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict)
|
||||
case v0 of
|
||||
Nothing -> do
|
||||
put sto k (LBS.toStrict $ serialise w)
|
||||
|
||||
Just (Left{}) -> do
|
||||
put sto k (LBS.toStrict $ serialise w)
|
||||
|
||||
Just (Right prev) | getSequence w > getSequence prev -> do
|
||||
put sto k (LBS.toStrict $ serialise w)
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
compactStorageClose sto
|
||||
|
||||
cleanStage
|
||||
|
||||
importFromLog :: FixmePerks m => CompactStorage HbSync -> FixmeM m ()
|
||||
importFromLog sto = do
|
||||
fset <- listAllFixmeHashes
|
||||
|
||||
-- sto <- compactStorageOpen @HbSync readonly fn
|
||||
ks <- keys sto
|
||||
|
||||
toImport <- S.toList_ do
|
||||
for_ ks $ \k -> runMaybeT do
|
||||
v <- get sto k & MaybeT
|
||||
what <- deserialiseOrFail @CompactAction (LBS.fromStrict v) & toMPlus
|
||||
|
||||
case what of
|
||||
Added _ fx -> do
|
||||
let ha = hashObject @HbSync (serialise fx) & HashRef
|
||||
unless (HS.member ha fset) do
|
||||
warn $ red "import" <+> viaShow (pretty ha)
|
||||
lift $ S.yield (Right fx)
|
||||
w -> lift $ S.yield (Left $ fromRight mempty $ parseTop (show $ pretty w))
|
||||
|
||||
withState $ transactional do
|
||||
for_ (rights toImport) insertFixme
|
||||
|
||||
let w = lefts toImport
|
||||
runForms (mconcat w)
|
||||
|
||||
unless (List.null toImport) do
|
||||
updateIndexes
|
||||
|
||||
-- compactStorageClose sto
|
||||
|
||||
printEnv :: FixmePerks m => FixmeM m ()
|
||||
printEnv = do
|
||||
g <- asks fixmeEnvGitDir >>= readTVarIO
|
||||
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))
|
||||
|
||||
for_ g $ \git -> do
|
||||
liftIO $ print $ "fixme-git-dir" <+> dquotes (pretty git)
|
||||
|
||||
dbPath <- asks fixmeEnvDbPath >>= readTVarIO
|
||||
liftIO $ print $ "fixme-state-path" <+> dquotes (pretty dbPath)
|
||||
|
||||
(before,after) <- asks fixmeEnvCatContext >>= readTVarIO
|
||||
|
||||
liftIO $ print $ "fixme-def-context" <+> pretty before <+> pretty after
|
||||
|
||||
ma <- asks fixmeEnvMacro >>= readTVarIO <&> HM.toList
|
||||
|
||||
for_ ma $ \(n, syn) -> do
|
||||
liftIO $ print $ parens ("define-macro" <+> pretty n <+> pretty syn)
|
||||
|
||||
|
||||
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)
|
||||
|
||||
|
||||
runForms :: forall c m . (IsContext c, Data c, Data (Context c), FixmePerks m)
|
||||
=> [Syntax c]
|
||||
-> FixmeM m ()
|
||||
runForms ss = for_ ss $ \s -> do
|
||||
|
||||
macros <- asks fixmeEnvMacro >>= readTVarIO
|
||||
|
||||
debug $ pretty s
|
||||
|
||||
case s of
|
||||
|
||||
(ListVal (SymbolVal name : rest)) | HM.member name macros -> do
|
||||
let repl = [ (mkId ("$",i), syn) | (i,syn) <- zip [1..] rest ]
|
||||
maybe1 (inject repl (HM.lookup name macros)) none $ \macro -> do
|
||||
debug $ yellow "run macro" <+> pretty macro
|
||||
runForms [macro]
|
||||
|
||||
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-git-dir", StringLike g] -> do
|
||||
ta <- asks fixmeEnvGitDir
|
||||
atomically $ writeTVar ta (Just g)
|
||||
|
||||
ListVal [SymbolVal "fixme-state-path", StringLike g] -> do
|
||||
p <- asks fixmeEnvDbPath
|
||||
db <- asks fixmeEnvDb
|
||||
atomically do
|
||||
writeTVar p g
|
||||
writeTVar db Nothing
|
||||
|
||||
evolve
|
||||
|
||||
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", TimeStampLike _, FixmeHashLike hash] -> do
|
||||
deleteFixme hash
|
||||
|
||||
ListVal [SymbolVal "deleted", FixmeHashLike hash] -> do
|
||||
deleteFixme hash
|
||||
|
||||
ListVal [SymbolVal "added", FixmeHashLike _] -> do
|
||||
-- we don't add fixmies at this stage
|
||||
-- but in fixme-import
|
||||
none
|
||||
|
||||
ReadFixmeStdin -> readFixmeStdin
|
||||
|
||||
ListVal [SymbolVal "print-env"] -> printEnv
|
||||
|
||||
ListVal (SymbolVal "hello" : xs) -> do
|
||||
notice $ "hello" <+> pretty xs
|
||||
|
||||
ListVal [SymbolVal "define-macro", SymbolVal name, macro@(ListVal{})] -> do
|
||||
debug $ yellow "define-macro" <+> pretty name <+> pretty macro
|
||||
macros <- asks fixmeEnvMacro
|
||||
atomically $ modifyTVar macros (HM.insert name (fixContext macro))
|
||||
|
||||
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 "update-action" : xs) -> do
|
||||
debug $ "update-action" <+> pretty xs
|
||||
env <- ask
|
||||
t <- asks fixmeEnvReadLogActions
|
||||
let action = ReadLogAction @c $ \_ -> liftIO (withFixmeEnv env (runForms xs))
|
||||
atomically $ modifyTVar t (<> [action])
|
||||
|
||||
ListVal [SymbolVal "import-git-logs", StringLike fn] -> do
|
||||
warn $ red "import-git-logs" <+> pretty fn
|
||||
scanGitLogLocal fn importFromLog
|
||||
|
||||
ListVal [SymbolVal "import", StringLike fn] -> do
|
||||
warn $ red "IMPORT" <+> pretty fn
|
||||
sto <- compactStorageOpen readonly fn
|
||||
importFromLog sto
|
||||
compactStorageClose sto
|
||||
|
||||
ListVal [SymbolVal "export", StringLike fn] -> do
|
||||
warn $ red "EXPORT" <+> pretty fn
|
||||
exportToLog fn
|
||||
|
||||
ListVal [SymbolVal "git:list-refs"] -> do
|
||||
refs <- listRefs False
|
||||
for_ refs $ \(h,r) -> do
|
||||
liftIO $ print $ pretty h <+> pretty r
|
||||
|
||||
ListVal [SymbolVal "git:merge-binary-log",StringLike o, StringLike target, StringLike b] -> do
|
||||
debug $ red "git:merge-binary-log" <+> pretty o <+> pretty target <+> pretty b
|
||||
|
||||
temp <- liftIO $ emptyTempFile "." "merge-result"
|
||||
sa <- compactStorageOpen @HbSync readonly o
|
||||
sb <- compactStorageOpen @HbSync readonly b
|
||||
r <- compactStorageOpen @HbSync mempty temp
|
||||
|
||||
for_ [sa,sb] $ \sto -> do
|
||||
ks <- keys sto
|
||||
for_ ks $ \k -> runMaybeT do
|
||||
v <- get sto k & MaybeT
|
||||
put r k v
|
||||
|
||||
compactStorageClose r
|
||||
compactStorageClose sa
|
||||
compactStorageClose sb
|
||||
|
||||
mv temp target
|
||||
|
||||
ListVal [SymbolVal "no-debug"] -> do
|
||||
setLoggingOff @DEBUG
|
||||
|
||||
ListVal [SymbolVal "silence"] -> do
|
||||
silence
|
||||
|
||||
ListVal [SymbolVal "builtin:run-stdin"] -> do
|
||||
let ini = mempty :: [Text]
|
||||
flip fix ini $ \next acc -> do
|
||||
eof <- liftIO IO.isEOF
|
||||
s <- if eof then pure "" else liftIO Text.getLine <&> Text.strip
|
||||
if Text.null s then do
|
||||
let code = parseTop (Text.unlines acc) & fromRight mempty
|
||||
runForms code
|
||||
unless eof do
|
||||
next mempty
|
||||
else do
|
||||
next (acc <> [s])
|
||||
|
||||
ListVal [SymbolVal "builtin:evolve"] -> do
|
||||
evolve
|
||||
|
||||
ListVal [SymbolVal "builtin:list-commits"] -> do
|
||||
co <- listCommits
|
||||
liftIO $ print $ vcat (fmap (pretty . view _1) co)
|
||||
|
||||
ListVal [SymbolVal "builtin:cleanup-state"] -> do
|
||||
cleanupDatabase
|
||||
|
||||
ListVal [SymbolVal "builtin:clean-stage"] -> do
|
||||
cleanStage
|
||||
|
||||
ListVal [SymbolVal "builtin:drop-stage"] -> do
|
||||
cleanStage
|
||||
|
||||
ListVal [SymbolVal "builtin:show-stage"] -> do
|
||||
stage <- selectStage
|
||||
liftIO $ print $ vcat (fmap pretty stage)
|
||||
|
||||
ListVal [SymbolVal "builtin:show-log", StringLike fn] -> do
|
||||
sto <- compactStorageOpen @HbSync readonly fn
|
||||
|
||||
ks <- keys sto
|
||||
|
||||
entries <- mapM (get sto) ks
|
||||
<&> catMaybes
|
||||
<&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict)
|
||||
<&> rights
|
||||
|
||||
liftIO $ print $ vcat (fmap pretty entries)
|
||||
|
||||
compactStorageClose sto
|
||||
|
||||
ListVal [SymbolVal "builtin:update-indexes"] -> do
|
||||
updateIndexes
|
||||
|
||||
ListVal [SymbolVal "builtin:scan-magic"] -> do
|
||||
magic <- scanMagic
|
||||
liftIO $ print $ pretty magic
|
||||
|
||||
ListVal [SymbolVal "builtin:select-fixme-hash", FixmeHashLike x] -> do
|
||||
w <- selectFixmeHash x
|
||||
liftIO $ print $ pretty w
|
||||
|
||||
ListVal [SymbolVal "builtin:git:list-stage"] -> do
|
||||
stage <- gitListStage
|
||||
for_ stage $ \case
|
||||
Left (fn,h) -> liftIO $ print $ "N" <+> pretty h <+> pretty fn
|
||||
Right (fn,h) -> liftIO $ print $ "E" <+> pretty h <+> pretty fn
|
||||
|
||||
ListVal (SymbolVal "builtin:git:extract-file-meta-data" : StringLikeList fs) -> do
|
||||
fxm <- gitExtractFileMetaData fs <&> HM.toList
|
||||
liftIO $ print $ vcat (fmap (pretty.snd) fxm)
|
||||
|
||||
ListVal (SymbolVal "builtin:git:extract-from-stage" : opts) -> do
|
||||
env <- ask
|
||||
gitStage <- gitListStage
|
||||
|
||||
let dry = or [ True | StringLike "dry" <- opts ]
|
||||
let verbose = or [ True | StringLike "verbose" <- opts ]
|
||||
|
||||
blobs <- for gitStage $ \case
|
||||
Left (fn, hash) -> pure (fn, hash, liftIO $ LBS8.readFile fn)
|
||||
Right (fn,hash) -> pure (fn, hash, liftIO (withFixmeEnv env $ gitCatBlob hash))
|
||||
|
||||
let fns = fmap (view _1) blobs
|
||||
|
||||
-- TODO: extract-metadata-from-git-blame
|
||||
-- subj
|
||||
|
||||
stageFile <- localConfigDir <&> (</> "current-stage.log")
|
||||
|
||||
fmeStage <- compactStorageOpen mempty stageFile
|
||||
|
||||
for_ blobs $ \(fn, bhash, readBlob) -> do
|
||||
nno <- newTVarIO (mempty :: HashMap FixmeTitle Integer)
|
||||
lbs <- readBlob
|
||||
fxs <- scanBlob (Just fn) lbs
|
||||
>>= \e -> do
|
||||
for e $ \fx0 -> do
|
||||
n <- atomically $ stateTVar nno (\m -> do
|
||||
let what = HM.lookup (fixmeTitle fx0) m & fromMaybe 0
|
||||
(what, HM.insert (fixmeTitle fx0) (succ what) m)
|
||||
)
|
||||
let ls = fixmePlain fx0
|
||||
meta <- getMetaDataFromGitBlame fn fx0
|
||||
let tit = fixmeTitle fx0 & coerce @_ @Text
|
||||
|
||||
-- FIXME: fix-this-copypaste
|
||||
let ks = [qc|{fn}#{tit}:{n}|] :: Text
|
||||
let ksh = hashObject @HbSync (serialise ks) & pretty & show & Text.pack & FixmeAttrVal
|
||||
let kh = HM.singleton "fixme-key" ksh
|
||||
let kv = HM.singleton "fixme-key-string" (FixmeAttrVal ks) <> kh
|
||||
|
||||
pure $ fixmeDerivedFields (fx0 <> mkFixmeFileName fn <> meta)
|
||||
& set (field @"fixmePlain") ls
|
||||
|
||||
& over (field @"fixmeAttr")
|
||||
(HM.insert "blob" (fromString $ show $ pretty bhash))
|
||||
& over (field @"fixmeAttr")
|
||||
(mappend (kh<>kv))
|
||||
|
||||
unless dry do
|
||||
for_ fxs $ \fx -> void $ runMaybeT do
|
||||
e <- getEpoch
|
||||
let what = Added e fx
|
||||
let k = mkKey (FromFixmeKey fx)
|
||||
get fmeStage k >>= guard . isNothing
|
||||
put fmeStage k (LBS.toStrict $ serialise what)
|
||||
|
||||
when verbose do
|
||||
liftIO $ print (pretty fx)
|
||||
|
||||
when dry do
|
||||
warn $ red "FUCKING DRY!"
|
||||
|
||||
compactStorageClose fmeStage
|
||||
|
||||
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)
|
||||
|
||||
|
||||
|
|
@ -389,18 +389,18 @@ instance IsContext c => HasPredicate [Syntax c] where
|
|||
go = \case
|
||||
|
||||
( SymbolVal "!" : rest ) -> do
|
||||
mklist [mksym "not", unlist (go rest)]
|
||||
mkList [mkSym "not", unlist (go rest)]
|
||||
|
||||
( Operand a : SymbolVal "~" : Operand b : rest ) -> do
|
||||
go (mklist [mksym "like", mkstr a, mkstr b] : rest)
|
||||
go (mkList [mkSym "like", mkStr a, mkStr b] : rest)
|
||||
|
||||
( w : SymbolVal "&&" : rest ) -> do
|
||||
mklist [mksym "and", unlist w, unlist (go rest)]
|
||||
mkList [mkSym "and", unlist w, unlist (go rest)]
|
||||
|
||||
( w : SymbolVal "||" : rest ) -> do
|
||||
mklist [mksym "or", unlist w, unlist (go rest)]
|
||||
mkList [mkSym "or", unlist w, unlist (go rest)]
|
||||
|
||||
w -> mklist w
|
||||
w -> mkList w
|
||||
|
||||
unlist = \case
|
||||
ListVal [x] -> x
|
||||
|
|
|
|||
|
|
@ -43,23 +43,6 @@ pattern FixmeHashLike e <- (fixmeHashFromSyn -> Just e)
|
|||
pattern TimeStampLike :: forall {c} . FixmeTimestamp -> Syntax c
|
||||
pattern TimeStampLike e <- (tsFromFromSyn -> Just e)
|
||||
|
||||
fixContext :: IsContext c => Syntax c -> Syntax C
|
||||
fixContext = go
|
||||
where
|
||||
go = \case
|
||||
List _ xs -> List noContext (fmap go xs)
|
||||
Symbol _ w -> Symbol noContext w
|
||||
Literal _ l -> Literal noContext l
|
||||
|
||||
mklist :: IsContext c => [Syntax c] -> Syntax c
|
||||
mklist = List noContext
|
||||
|
||||
mkint :: (IsContext c, Integral a) => a -> Syntax c
|
||||
mkint = Literal noContext . LitInt . fromIntegral
|
||||
|
||||
mksym :: IsContext c => Id -> Syntax c
|
||||
mksym = Symbol noContext
|
||||
|
||||
class MkId a where
|
||||
mkId :: a -> Id
|
||||
|
||||
|
|
@ -72,45 +55,6 @@ instance MkId (Text,Int) where
|
|||
instance MkId (String,Integer) where
|
||||
mkId (p, i) = Id (fromString p <> fromString (show i))
|
||||
|
||||
class IsContext c => MkStr c a where
|
||||
mkstr :: a -> Syntax c
|
||||
|
||||
|
||||
instance IsContext c => MkStr c String where
|
||||
mkstr s = Literal (noContext @c) (LitStr $ Text.pack s)
|
||||
|
||||
instance IsContext c => MkStr c ByteString where
|
||||
mkstr s = Literal (noContext @c) (LitStr $ Text.pack $ BS8.unpack s)
|
||||
|
||||
instance IsContext c => MkStr c (Maybe FixmeKey) where
|
||||
mkstr Nothing = Literal (noContext @c) (LitStr "")
|
||||
mkstr (Just k) = Literal (noContext @c) (LitStr (coerce k))
|
||||
|
||||
instance IsContext c => MkStr c FixmeAttrVal where
|
||||
mkstr (s :: FixmeAttrVal) = Literal (noContext @c) (LitStr (coerce s))
|
||||
|
||||
|
||||
instance IsContext c => MkStr c (Maybe FixmeAttrVal) where
|
||||
mkstr (Just v) = mkstr v
|
||||
mkstr Nothing = mkstr ( "" :: Text )
|
||||
|
||||
instance IsContext c => MkStr c FixmeAttrName where
|
||||
mkstr (s :: FixmeAttrName) = Literal (noContext @c) (LitStr (coerce s))
|
||||
|
||||
instance IsContext c => MkStr c HashRef where
|
||||
mkstr s = Literal (noContext @c) (LitStr (fromString $ show $ pretty s))
|
||||
|
||||
instance IsContext c => MkStr c Text where
|
||||
mkstr = Literal noContext . LitStr
|
||||
|
||||
stringLike :: Syntax c -> Maybe String
|
||||
stringLike = \case
|
||||
LitStrVal s -> Just $ Text.unpack s
|
||||
SymbolVal (Id s) -> Just $ Text.unpack s
|
||||
_ -> Nothing
|
||||
|
||||
stringLikeList :: [Syntax c] -> [String]
|
||||
stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
|
||||
|
||||
fixmeHashFromSyn :: Syntax c -> Maybe Text
|
||||
fixmeHashFromSyn = \case
|
||||
|
|
@ -235,13 +179,25 @@ instance MkKey (FromFixmeKey Fixme) where
|
|||
maybe k2 (mappend "A" . LBS.toStrict . serialise) (HM.lookup "fixme-key" fixmeAttr)
|
||||
where k2 = mappend "A" $ serialise fx & LBS.toStrict
|
||||
|
||||
instance IsContext c => MkStr c HashRef where
|
||||
mkStr ha = mkStr (show $ pretty ha)
|
||||
|
||||
instance IsContext c => MkStr c FixmeAttrVal where
|
||||
mkStr v = mkStr (coerce @_ @Text v)
|
||||
|
||||
instance IsContext c => MkStr c (AsBase58 ByteString) where
|
||||
mkStr v = mkStr (show $ pretty v)
|
||||
|
||||
instance IsContext c => MkStr c FixmeAttrName where
|
||||
mkStr v = mkStr (coerce @_ @Text v)
|
||||
|
||||
instance Pretty CompactAction where
|
||||
pretty = \case
|
||||
Deleted s r -> pretty $ mklist @C [ mksym "deleted", mkint s, mkstr r ]
|
||||
Modified s r k v -> pretty $ mklist @C [ mksym "modified", mkint s, mkstr r, mkstr k, mkstr v ]
|
||||
Deleted s r -> pretty $ mkList @C [ mkSym "deleted", mkInt s, mkStr r ]
|
||||
Modified s r k v -> pretty $ mkList @C [ mkSym "modified", mkInt s, mkStr r, mkStr k, mkStr v ]
|
||||
-- FIXME: normal-pretty-instance
|
||||
e@(Added w fx) -> do
|
||||
pretty $ mklist @C [ mksym "added", mkstr (toBase58 $ mkKey e) ]
|
||||
pretty $ mkList @C [ mkSym "added", mkStr (AsBase58 $ mkKey e) ]
|
||||
|
||||
instance Serialise CompactAction
|
||||
|
||||
|
|
@ -362,9 +318,6 @@ fixmeEnvBare =
|
|||
withFixmeEnv :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a
|
||||
withFixmeEnv env what = runReaderT ( fromFixmeM what) env
|
||||
|
||||
-- FIXME: move-to-suckless-conf-library
|
||||
deriving newtype instance Hashable Id
|
||||
|
||||
instance Serialise FixmeTag
|
||||
instance Serialise FixmeTitle
|
||||
instance Serialise FixmePlainLine
|
||||
|
|
|
|||
Loading…
Reference in New Issue