diff --git a/.fixme-new/config b/.fixme-new/config index de60dedb..0b5ee2e1 100644 --- a/.fixme-new/config +++ b/.fixme-new/config @@ -40,7 +40,20 @@ fixme-comments ";" "--" (fixme-play-log-action ) -update +;(define-template default +; (simple +; ($fixme-key) | ($fixme-title) (nl) +; ) +;) + +(define-template short + (simple + ($fixme-key) (nl) + ) +) + + +;update diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 2c64cc9d..2a395234 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -31,6 +31,7 @@ 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 Data.Text.IO qualified as Text import Data.Text.Encoding qualified as Text import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (ignore) @@ -121,6 +122,7 @@ runFixmeCLI m = do <*> newTVarIO Nothing <*> newTVarIO mempty <*> newTVarIO mempty + <*> newTVarIO mempty runReaderT ( setupLogger >> fromFixmeM (evolve >> m) ) env `finally` flushLoggers @@ -470,10 +472,31 @@ readFixmeStdin = do fixmies <- Scan.scanBlob Nothing what liftIO $ print $ vcat (fmap pretty fixmies) -list_ :: (FixmePerks m, HasPredicate a) => a -> FixmeM m () -list_ a = do + + +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 - liftIO $ LBS.putStr $ Aeson.encodePretty fixmies + + 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 v) | (k,v) <- HM.toList attr ] + let what = render (SimpleTemplate (inject subst simple)) + & fromRight "render error" + + liftIO $ Text.putStr what + + where + mksym (k :: FixmeAttrName) = Id ("$" <> coerce k) + mkstr (s :: FixmeAttrVal) = Literal cc (LitStr (coerce s)) + cc = noContext :: Context C cat_ :: FixmePerks m => Text -> FixmeM m () cat_ hash = void $ flip runContT pure do @@ -546,7 +569,8 @@ help = do notice "this is help message" -- FIXME: tied-context-type -inject :: forall a c . (Data c, Data (Context c), Data a) => [(Id,Syntax c)] -> a -> a +inject :: forall c a . (Data c, Data (Context c), Data a) => [(Id,Syntax c)] -> a -> a +-- inject ::(Data C, Data (Context C), Data a) => [(Id,Syntax C)] -> a -> a inject repl target = flip transformBi target $ \case w@(SymbolVal x) -> fromMaybe w (Map.lookup x rmap) @@ -568,6 +592,17 @@ sanitizeLog lls = flip filter lls $ \case ListVal (SymbolVal "deleted" : _) -> 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 @@ -628,11 +663,13 @@ run what = do Update args -> scanGitLocal args Nothing - ListVal [SymbolVal "list"] -> do - list_ () + ListVal (SymbolVal "list" : (Template n [])) -> do + debug $ "list" <+> pretty n + list_ n () - ListVal (SymbolVal "list" : whatever) -> do - list_ whatever + ListVal (SymbolVal "list" : (Template n whatever)) -> do + debug $ "list" <+> pretty n + list_ n whatever ListVal [SymbolVal "cat", FixmeHashLike hash] -> do cat_ hash @@ -651,6 +688,11 @@ run what = do ListVal (SymbolVal "hello" : xs) -> do notice $ "hello" <+> pretty xs + ListVal (SymbolVal "define-template" : SymbolVal who : IsSimpleTemplate xs) -> do + debug $ "define-template" <+> pretty who <+> "simple" <+> hsep (fmap pretty xs) + t <- asks fixmeEnvTemplates + atomically $ modifyTVar t (HM.insert who (Simple (SimpleTemplate xs))) + -- FIXME: maybe-rename-fixme-update-action ListVal (SymbolVal "fixme-update-action" : xs) -> do debug $ "fixme-update-action" <+> pretty xs diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index db60f3b6..e58bd78f 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -36,6 +36,8 @@ import Lens.Micro.Platform import Data.Generics.Product.Fields (field) import Control.Monad.Trans.Maybe import Data.Coerce +import Data.Fixed +import System.TimeIt pattern Operand :: forall {c} . Text -> Syntax c @@ -370,11 +372,15 @@ selectFixmeThin a = withState do let sql = [qc| +with actual as ( + select x.fixme, f.ts from fixmeactualview x join fixme f on x.fixme = f.id + ) + select - cast(json_set(json_group_object(a.name,a.value), '$."fixme-hash"', a.fixme) as blob) + cast(json_set(json_group_object(a.name,a.value), '$."fixme-hash"', f.fixme) as blob) from - fixmeattrview a join fixme f on a.fixme = f.id + fixmeattrview a join actual f on f.fixme = a.fixme where @@ -382,17 +388,20 @@ where {fst predic} ) - and exists (select null from fixmeactualview where fixme = f.id) - group by a.fixme order by f.ts nulls first |] - trace $ yellow "selectFixmeThin" <> line <> pretty sql - select sql (snd predic) <&> mapMaybe (Aeson.decode @FixmeThin . fromOnly) + (t,r) <- timeItT $ select sql (snd predic) <&> mapMaybe (Aeson.decode @FixmeThin . fromOnly) + trace $ yellow "selectFixmeThin" <> line + <> pretty sql <> line + <> pretty (length r) <+> "rows" <> line + <> pretty "elapsed" <+> pretty (realToFrac t :: Fixed E6) + + pure r cleanupDatabase :: (FixmePerks m, MonadReader FixmeEnv m) => m () cleanupDatabase = do diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 2bc9bfd3..7ce33a35 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -130,6 +130,18 @@ data UpdateAction = forall c . IsContext c => UpdateAction { runUpdateAction :: data ReadLogAction = forall c . IsContext c => ReadLogAction { runReadLog :: Syntax c -> IO () } +-- FIXME: fucking-context-hardcode-wtf +data SimpleTemplate = forall c . (IsContext c, Data (Context c), Data c) => SimpleTemplate [Syntax c] + +data FixmeTemplate = + Simple SimpleTemplate + +data RenderError = RenderError String + deriving stock (Eq,Show,Typeable) + +class FixmeRenderTemplate a where + render :: a -> Either RenderError Text + data FixmeEnv = FixmeEnv { fixmeEnvGitDir :: Maybe FilePath @@ -143,6 +155,7 @@ data FixmeEnv = , fixmeEnvGitScanDays :: TVar (Maybe Integer) , fixmeEnvUpdateActions :: TVar [UpdateAction] , fixmeEnvReadLogActions :: TVar [ReadLogAction] + , fixmeEnvTemplates :: TVar (HashMap Id FixmeTemplate) } @@ -181,6 +194,9 @@ newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a } 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 @@ -274,4 +290,22 @@ commentKey fp = "" -> takeFileName fp xs -> xs +pattern NL :: forall {c}. Syntax c +pattern NL <- ListVal [SymbolVal "nl"] + +instance FixmeRenderTemplate SimpleTemplate where + render (SimpleTemplate syn) = + Right $ Text.concat $ + flip fix (mempty,syn) $ \next -> \case + (acc, NL : rest) -> next (acc <> nl, rest) + (acc, ListVal [StringLike w] : rest) -> next (acc <> txt w, rest) + (acc, StringLike w : rest) -> next (acc <> txt w, rest) + (acc, e : rest) -> next (acc <> p e, rest) + (acc, []) -> acc + + where + nl = [ "\n" ] + txt s = [fromString s] + p e = [Text.pack (show $ pretty e)] +