wip, cat command and pager

.fixme-new/config

@@ -38,6 +38,7 @@ fixme-comments ";" "--"
 )
 
 (fixme-play-log-action
+;  (hello kitty)
 )
 
 (define-template short
@@ -61,6 +62,8 @@ fixme-comments ";" "--"
   )
 )
 
+(set-template default short)
+
 ; update
 
 

.fixme-new/log

@@ -0,0 +1,2 @@
+deleted "6R2raAzjbViHZVk24zwUr7rwgfepHTdXeW6Lbqw3q25A"
+deleted "DtcQir9mHe7R5ixYGXTbsXGPeVGV8TqAMmrvYgGy1wGB"

fixme-new/lib/Fixme/Config.hs

@@ -5,6 +5,7 @@ import Fixme.Types
 
 import HBS2.System.Dir
 import System.Environment
+import System.Directory
 
 binName :: FixmePerks m => m FilePath
 binName = liftIO getProgName
@@ -18,6 +19,17 @@ localConfigDir = do
 localConfig:: FixmePerks m => m FilePath
 localConfig = localConfigDir <&> (</> "config")
 
+userConfigs :: FixmePerks m => m [FilePath]
+userConfigs= do
+  bin <- binName
+  h <- home
+  xdg <- liftIO (getXdgDirectory XdgConfig bin)
+
+  let conf1 = h </> ("." <> bin)
+  let conf2 = xdg </> "config"
+
+  pure [conf2, conf1]
+
 localDBName :: FilePath
 localDBName = "state.db"
 

fixme-new/lib/Fixme/Run.hs

@@ -134,7 +134,9 @@ runFixmeCLI m = do
             <*>  newTVarIO Nothing
             <*>  newTVarIO mempty
             <*>  newTVarIO mempty
+            <*>  newTVarIO defaultCatAction
             <*>  newTVarIO defaultTemplate
+            <*>  newTVarIO (1,3)
 
   runReaderT ( setupLogger >> fromFixmeM (evolve >> m) ) env
                  `finally` flushLoggers
@@ -148,6 +150,10 @@ runFixmeCLI m = do
     flushLoggers = do
       silence
 
+    -- FIXME: tied-fucking-context
+    defaultCatAction = CatAction $ \dict lbs -> do
+      LBS.putStr lbs
+      pure ()
 
 silence :: FixmePerks m => m ()
 silence = do
@@ -160,11 +166,17 @@ silence = do
 
 readConfig :: FixmePerks m => FixmeM m [Syntax C]
 readConfig = do
-  localConfig
+
-     >>= try @_ @IOException . liftIO . readFile
+  user <- userConfigs
-     <&> fromRight mempty
+  lo   <- localConfig
-     <&> parseTop
+
-     <&> fromRight mempty
+  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
@@ -503,28 +515,58 @@ list_ tpl a = do
 
     Just (Simple (SimpleTemplate simple)) -> do
       for_ fixmies $ \(FixmeThin attr) -> do
-        let subst = [ (mksym k, mkstr v) | (k,v) <- HM.toList attr ]
+        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
 
-  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
+cat_ hash = do
-  callCC \exit -> do
 
-    mha <- lift $ selectFixmeHash hash
+  (before,after)  <- asks fixmeEnvCatContext >>= readTVarIO
+  gd  <- fixmeGetGitDirCLIOpt
 
-    ha <- ContT $ maybe1 mha (pure ())
+  CatAction action <- asks fixmeEnvCatAction >>= readTVarIO
 
-    fme <- lift $ selectFixme ha
+  void $ flip runContT pure do
+    callCC \exit -> do
 
-    notice $ pretty fme
+      mha <- lift $ selectFixmeHash hash
+
+      ha <- ContT $ maybe1 mha (pure ())
+
+      fme' <- lift $ selectFixme ha
+
+      Fixme{..} <- ContT $ maybe1 fme' (pure ())
+
+      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
@@ -580,6 +622,12 @@ printEnv = do
   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"
@@ -659,6 +707,30 @@ run what = 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
@@ -701,6 +773,12 @@ run what = do
           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

fixme-new/lib/Fixme/Types.hs

@@ -14,6 +14,7 @@ import Data.Config.Suckless
 import Prettyprinter.Render.Terminal
 import Control.Applicative
 import Data.Aeson
+import Data.ByteString.Lazy (ByteString)
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
 import Data.HashSet (HashSet)
@@ -91,6 +92,7 @@ newtype FixmeKey  = FixmeKey Text
 
 newtype FixmeOffset = FixmeOffset Word32
                      deriving newtype (Eq,Ord,Show,Num,ToField,FromField)
+                     deriving newtype (Integral,Real,Enum)
                      deriving stock (Data,Generic)
 
 
@@ -134,7 +136,9 @@ data UpdateAction = forall c . IsContext c => UpdateAction { runUpdateAction ::
 
 data ReadLogAction = forall c . IsContext c => ReadLogAction { runReadLog :: Syntax c -> IO () }
 
--- FIXME: fucking-context-hardcode-wtf
+-- FIXME: fucking-context-hardcode-wtf-1
+data CatAction = CatAction { catAction :: [(Id, Syntax C)] -> ByteString -> IO () }
+
 data SimpleTemplate = forall c . (IsContext c, Data (Context c), Data c) => SimpleTemplate [Syntax c]
 
 data FixmeTemplate =
@@ -159,7 +163,9 @@ data FixmeEnv =
   , fixmeEnvGitScanDays    :: TVar (Maybe Integer)
   , fixmeEnvUpdateActions  :: TVar [UpdateAction]
   , fixmeEnvReadLogActions :: TVar [ReadLogAction]
+  , fixmeEnvCatAction      :: TVar CatAction
   , fixmeEnvTemplates      :: TVar (HashMap Id FixmeTemplate)
+  , fixmeEnvCatContext     :: TVar (Int,Int)
   }
 
 
@@ -294,7 +300,18 @@ commentKey fp =
     "" -> takeFileName fp
     xs -> xs
 
-inject :: forall c  a . (IsContext c, Data c, Data (Context c), Data a) => [(Id,Syntax c)] -> a -> a
+type ContextShit c = (Data c, Data (Context c), IsContext c)
+
+mksym :: FixmeAttrName -> Id
+mksym (k :: FixmeAttrName) = Id ("$" <> coerce k)
+
+mkstr :: forall c . (IsContext c) => FixmeAttrVal -> Syntax c
+mkstr (s :: FixmeAttrVal)  = Literal (noContext @c) (LitStr (coerce s))
+
+cc0 :: forall c . ContextShit c => Context c
+cc0 = noContext :: Context c
+
+inject :: forall c  a . (ContextShit c, Data a) => [(Id,Syntax c)] -> a -> a
 inject repl target =
   flip transformBi target $ \case
    (SymbolVal x) | issubst x -> fromMaybe mt (Map.lookup x rmap)
@@ -341,7 +358,7 @@ instance FixmeRenderTemplate SimpleTemplate (Doc AnsiStyle) where
 
     where
 
-      evaluated :: (IsContext c, Data (Context c), Data c) => Syntax c -> Maybe  Text
+      evaluated :: (ContextShit c) => Syntax c -> Maybe  Text
       evaluated what = Just (deep' [what] & Text.concat)
 
       color_ = \case
@@ -377,10 +394,10 @@ instance FixmeRenderTemplate SimpleTemplate (Doc AnsiStyle) where
           n = fromIntegral n0
           s = mconcat s0
 
-      deep :: forall c . (IsContext c, Data (Context c), Data c) => [Syntax c] -> [Doc AnsiStyle]
+      deep :: forall c . (ContextShit c) => [Syntax c] -> [Doc AnsiStyle]
       deep sy = either mempty List.singleton (render (SimpleTemplate sy))
 
-      deep' :: forall c . (IsContext c, Data (Context c), Data c) => [Syntax c] -> [Text]
+      deep' :: forall c . (ContextShit c) => [Syntax c] -> [Text]
       deep' sy = do
         let what = deep sy
         [ Text.pack (show x) | x <- what]
@@ -417,7 +434,7 @@ instance FixmeRenderTemplate SimpleTemplate Text where
           n = fromIntegral n0
           s = mconcat s0
 
-      deep :: forall c . (IsContext c, Data (Context c), Data c) => [Syntax c] -> [Text]
+      deep :: forall c . (ContextShit c) => [Syntax c] -> [Text]
       deep sy = either mempty List.singleton (render (SimpleTemplate sy))
 
       nl = [ "\n" ]

hbs2-core/lib/HBS2/System/Dir.hs

@@ -69,4 +69,7 @@ expandPath = liftIO . D.canonicalizePath
 doesDirectoryExist :: MonadIO m => FilePath -> m Bool
 doesDirectoryExist = liftIO . D.doesDirectoryExist
 
+home :: MonadIO m => m FilePath
+home = liftIO D.getHomeDirectory
+