wip

.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
 
 
 

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,11 +472,32 @@ 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
+
+  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
   callCC \exit -> 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

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

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)]
+