wip

fixme-new/lib/Fixme/Run.hs

@@ -309,6 +309,24 @@ runTop forms = do
 
         _ -> throwIO $ BadFormException @C nil
 
+
+       entry $ bindMatch "dump" $ nil_ $ \case
+        [ FixmeHashLike w ] -> lift $ void $ runMaybeT do
+          key <- lift (selectFixmeKey w) >>= toMPlus
+          fme <- lift $ getFixme key
+          liftIO $ print $ pretty fme
+
+        _ -> throwIO $ BadFormException @C nil
+          -- magic <- lift $ asks fixmeEnvScanMagic >>= readTVarIO
+          -- liftIO $ print $ pretty magic
+
+       entry $ bindMatch "fixme:key:show" $ nil_ \case
+        [ FixmeHashLike w ] -> lift $ void $ runMaybeT do
+          key <- lift (selectFixmeKey w) >>= toMPlus
+          liftIO $ print $ pretty key
+
+        _ -> throwIO $ BadFormException @C nil
+
        entry $ bindMatch "fixme:scan-magic" $ nil_ $ const do
           magic <- lift $ asks fixmeEnvScanMagic >>= readTVarIO
           liftIO $ print $ pretty magic

fixme-new/lib/Fixme/Run/Internal.hs

@@ -182,7 +182,7 @@ scanFiles = do
         let keyText = key <> fromString (show no)
         let keyHash = FixmeKey $ fromString $ show $ pretty $ hashObject @HbSync (serialise keyText)
         let f2 = mempty { fixmeTs = Just (fromIntegral ts)
-                        , fixmeKey = Just keyHash
+                        , fixmeKey = keyHash
                         , fixmeAttr = HM.fromList
                             [   ( "fixme-key-string", FixmeAttrVal keyText)
                               , ( "file", FixmeAttrVal (fromString fnShort))

fixme-new/lib/Fixme/Scan.hs

@@ -179,7 +179,7 @@ scanBlob fpath lbs = do
       FixmeHead lno  _ tag title ->
           Fixme (FixmeTag tag)
                 (FixmeTitle title)
-                Nothing
+                mempty
                 Nothing
                 (Just (FixmeOffset (fromIntegral lno)))
                 Nothing

fixme-new/lib/Fixme/State.hs

@@ -7,22 +7,25 @@ module Fixme.State
   , insertFixme
   , insertScanned
   , selectIsAlreadyScanned
+  , selectFixmeKey
+  , getFixme
   , HasPredicate(..)
   , SelectPredicate(..)
   ) where
 
-import Fixme.Prelude
+import Fixme.Prelude hiding (key)
 import Fixme.Types
 import Fixme.Config
 
 import HBS2.System.Dir
-import Data.Config.Suckless
+import Data.Config.Suckless hiding (key)
 import Data.Config.Suckless.Syntax
 import DBPipe.SQLite hiding (field)
 
 import Data.HashSet (HashSet)
 import Data.HashSet qualified as HS
 import Data.Aeson as Aeson
+import Data.ByteString.Lazy qualified as LBS
 import Data.HashMap.Strict qualified as HM
 import Text.InterpolatedString.Perl6 (q,qc)
 import Data.Text qualified as Text
@@ -256,12 +259,37 @@ insertScanned file = do
               on conflict (hash) do nothing|]
          (Only k)
 
+selectFixmeKey :: (FixmePerks m, MonadReader FixmeEnv m) => Text -> m (Maybe FixmeKey)
+selectFixmeKey s = do
+  withState do
+    select @(Only FixmeKey) [qc|select distinct(o) from object where o like ? order by w desc|] (Only (s<>"%"))
+       <&> fmap fromOnly
+       <&> headMay
+
+getFixme :: (FixmePerks m, MonadReader FixmeEnv m) => FixmeKey -> m (Maybe Fixme)
+getFixme key = do
+
+  let sql = [qc|
+    select (cast (json_group_object(o.k, o.v) as blob)) as blob from object o
+    where o.o = ?
+    group by o.o
+    limit 1
+    |]
+
+  runMaybeT do
+
+    lift (withState $ select @(Only LBS.ByteString) sql (Only key))
+      <&> fmap (Aeson.decode @Fixme . fromOnly)
+      <&> catMaybes
+      <&> headMay
+      >>= toMPlus
+
 insertFixme :: (FixmePerks m, MonadReader FixmeEnv m) => Fixme -> DBPipeM m ()
 insertFixme fme = do
 
   void $ runMaybeT do
 
-    o   <- fixmeKey fme & toMPlus
+    let o = fixmeKey fme
     w   <-  fixmeTs fme & toMPlus
     let attrs   = fixmeAttr fme
     let txt = fixmePlain fme & Text.unlines . fmap coerce
@@ -281,6 +309,12 @@ insertFixme fme = do
             end
       |]
 
+    for_ (fixmeStart fme) $ \s -> do
+      lift $ insert sql (o,w,"fixme-start",s)
+
+    for_ (fixmeEnd fme) $ \s -> do
+      lift $ insert sql (o,w,"fixme-end",s)
+
     for_ (HM.toList attrs) $ \(k,v) -> do
       lift $ insert sql (o,w,k,v)
 

fixme-new/lib/Fixme/Types.hs

@@ -27,7 +27,10 @@ import Data.Config.Suckless
 
 import Prettyprinter.Render.Terminal
 import Control.Applicative
-import Data.Aeson
+import Data.Aeson as Aeson
+import Data.Aeson.KeyMap as Aeson hiding (null)
+import Data.Aeson.Key qualified as Aeson
+import Data.Aeson.Types as Aeson
 import Data.ByteString (ByteString)
 import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Lazy qualified as LBS
@@ -97,15 +100,15 @@ tsFromFromSyn = \case
   _ -> Nothing
 
 newtype FixmeTag = FixmeTag { fromFixmeTag :: Text }
-                   deriving newtype (Eq,Ord,Show,IsString,Hashable,Semigroup,Monoid,ToField,FromField)
+                   deriving newtype (Eq,Ord,Show,IsString,Hashable,Semigroup,Monoid,ToField,FromField,FromJSON,ToJSON)
                    deriving stock (Data,Generic)
 
 newtype FixmeTitle = FixmeTitle { fromFixmeTitle :: Text }
-                     deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField,Hashable)
+                     deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField,Hashable,FromJSON,ToJSON)
                      deriving stock (Data,Generic)
 
 newtype FixmePlainLine = FixmePlainLine { fromFixmeText :: Text }
-                         deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField)
+                         deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField,FromJSON,ToJSON)
                          deriving stock (Data,Generic)
 
 
@@ -121,16 +124,16 @@ newtype FixmeAttrVal = FixmeAttrVal { fromFixmeAttrVal :: Text }
                         deriving stock (Data,Generic)
 
 newtype FixmeTimestamp = FixmeTimestamp Word64
-                        deriving newtype (Eq,Ord,Show,Num,ToField,FromField)
+                        deriving newtype (Eq,Ord,Show,Num,ToField,FromField,ToJSON)
                         deriving stock (Data,Generic)
 
 
 newtype FixmeKey  = FixmeKey Text
-                    deriving newtype (Eq,Ord,Show,ToField,FromField,Pretty)
+                    deriving newtype (Eq,Ord,Show,ToField,FromField,Pretty,FromJSON,ToJSON,Semigroup,Monoid)
                     deriving stock (Data,Generic)
 
 newtype FixmeOffset = FixmeOffset Word32
-                     deriving newtype (Eq,Ord,Show,Num,ToField,FromField)
+                     deriving newtype (Eq,Ord,Show,Num,ToField,FromField,ToJSON)
                      deriving newtype (Integral,Real,Enum)
                      deriving stock (Data,Generic)
 
@@ -139,7 +142,7 @@ data Fixme =
   Fixme
   { fixmeTag       :: FixmeTag
   , fixmeTitle     :: FixmeTitle
-  , fixmeKey       :: Maybe FixmeKey
+  , fixmeKey       :: FixmeKey
   , fixmeTs        :: Maybe FixmeTimestamp
   , fixmeStart     :: Maybe FixmeOffset
   , fixmeEnd       :: Maybe FixmeOffset
@@ -149,7 +152,7 @@ data Fixme =
   deriving stock (Ord,Eq,Show,Data,Generic)
 
 instance Monoid Fixme where
-  mempty = Fixme mempty mempty Nothing Nothing Nothing Nothing mempty mempty
+  mempty = Fixme mempty mempty mempty Nothing Nothing Nothing mempty mempty
 
 instance Semigroup Fixme where
   (<>) a b = b { fixmeTs  = fixmeTs b <|> fixmeTs a
@@ -161,6 +164,57 @@ instance Semigroup Fixme where
                , fixmeAttr = fixmeAttr a <> fixmeAttr b
                }
 
+
+instance FromJSON FixmeOffset where
+  parseJSON = \case
+    Number x -> pure (FixmeOffset  (ceiling x))
+
+    String s  -> do
+      n <- maybe (fail "invalid FixmeOffset value") pure (readMay (Text.unpack s))
+      pure $ FixmeOffset n
+
+    _ -> fail "invalid FixmeOffset value"
+
+
+instance FromJSON FixmeTimestamp where
+  parseJSON = \case
+    Number x -> pure (FixmeTimestamp (ceiling x))
+
+    String s  -> do
+      n <- maybe (fail "invalid FixmeOffset value") pure (readMay (Text.unpack s))
+      pure $ FixmeTimestamp n
+
+    _ -> fail "invalid FixmeTimestamp value"
+
+
+instance FromJSON Fixme where
+  parseJSON = withObject "Fixme" $ \o -> do
+    fixmeKey   <- o .:  "fixme-key"
+    fixmeTag   <- o .:  "fixme-tag"
+    fixmeTitle <- o .:  "fixme-title"
+    fixmeStart <- o .:? "fixme-start"
+    fixmeEnd   <- o .:? "fixme-end"
+    fixmeTs    <- o .:? "fixme-timestamp"
+
+    fixmePlainTxt <- o .:? "fixme-text" <&> fromMaybe mempty
+    let fixmePlain = fmap FixmePlainLine (Text.lines fixmePlainTxt)
+
+    let wtf = [ unpackItem k v
+              | (k,v) <- Aeson.toList o
+              , k /= "fixme-text"
+              ] & catMaybes
+
+    let fixmeAttr = HM.fromList wtf
+
+    return Fixme{..}
+
+    where
+      unpackItem k v = do
+        (FixmeAttrName (Aeson.toText k),) <$>
+          case v of
+           String x -> pure (FixmeAttrVal x)
+           _        -> Nothing
+
 newtype FixmeThin = FixmeThin (HashMap FixmeAttrName FixmeAttrVal)
                     deriving newtype (Semigroup,Monoid,Eq,Ord,Show,ToJSON,FromJSON)
                     deriving stock (Data,Generic)
@@ -635,7 +689,7 @@ fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of
   (_,_) -> b
 
 fixmeDerivedFields :: Fixme -> Fixme
-fixmeDerivedFields fx = fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc
+fixmeDerivedFields fx = fxEnd <> fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc
   where
     email = HM.lookup "commiter-email" (fixmeAttr fx)
               & maybe mempty (\x -> " <" <> x <> ">")
@@ -645,7 +699,7 @@ fixmeDerivedFields fx = fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc
 
     tag = mempty { fixmeAttr = HM.singleton "fixme-tag" (FixmeAttrVal (coerce $ fixmeTag fx))  }
 
-    key = maybe mempty (  HM.singleton "fixme-key" . FixmeAttrVal . coerce) (fixmeKey fx)
+    key = HM.singleton "fixme-key" (FixmeAttrVal $ coerce $ (fixmeKey fx))
 
     fxKey = mempty { fixmeAttr = key }
 
@@ -653,6 +707,11 @@ fixmeDerivedFields fx = fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc
 
     fxLno = mempty { fixmeAttr = maybe mempty (HM.singleton "line") lno }
 
+    fxE = join $ for (fixmeStart fx) $ \n -> do
+            Just $ FixmeOffset $ fromIntegral $ fromIntegral n + length (fixmePlain fx)
+
+    fxEnd = mempty { fixmeEnd = fxE }
+
     fxCo =
       maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "committer" c }) comitter