wip

fixme-new/fixme.cabal

@@ -61,6 +61,8 @@ common shared-properties
       , suckless-conf
       , fuzzy-parse
 
+      , aeson
+      , aeson-pretty
       , attoparsec
       , atomic-write
       , bytestring

fixme-new/lib/Fixme/Run.hs

@@ -18,7 +18,10 @@ import DBPipe.SQLite hiding (field)
 import Data.Config.Suckless
 import Data.Text.Fuzzy.Tokenize
 
+import Data.Aeson as Aeson
+import Data.Aeson.Encode.Pretty as Aeson
 import Data.ByteString.Char8 qualified as BS
+import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Data.ByteString.Lazy (ByteString)
 import Data.Either
@@ -67,12 +70,6 @@ pattern FixmePrefix s <- ListVal [SymbolVal "fixme-prefix", fixmePrefix -> Just
 pattern FixmeGitScanFilterDays :: forall {c}. Integer -> Syntax c
 pattern FixmeGitScanFilterDays d <- ListVal [ SymbolVal "fixme-git-scan-filter-days", LitIntVal d ]
 
-pattern StringLike :: forall {c} . String -> Syntax c
-pattern StringLike e <- (stringLike -> Just e)
-
-pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
-pattern StringLikeList e <- (stringLikeList -> e)
-
 data ScanGitArgs =
     PrintBlobs
   | PrintFixme
@@ -94,14 +91,6 @@ scanGitArg = \case
 scanGitArgs :: [Syntax c] -> [ScanGitArgs]
 scanGitArgs syn = [ w | ScanGitArgs w <- syn ]
 
-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
 
 fileMasks :: [Syntax c] -> [FilePattern]
 fileMasks what = [ show (pretty s) | s <- what ]
@@ -420,10 +409,10 @@ readFixmeStdin = do
   fixmies <- Scan.scanBlob Nothing what
   liftIO $ print $ vcat (fmap pretty fixmies)
 
-list :: FixmePerks m => FixmeM m ()
+list_ :: (FixmePerks m, HasPredicate a) => a -> FixmeM m ()
-list = do
+list_ a = do
-  fixmies <- selectFixme ()
+  fixmies <- selectFixmeThin a
-  pure ()
+  liftIO $ LBS.putStr $ Aeson.encodePretty fixmies
 
 printEnv :: FixmePerks m => FixmeM m ()
 printEnv = do
@@ -533,6 +522,16 @@ run what = do
 
       Update args -> scanGitLocal args Nothing
 
+      ListVal [SymbolVal "list"] -> do
+        list_ ()
+
+      ListVal (SymbolVal "list" : whatever) -> do
+        list_ whatever
+
+      ListVal [SymbolVal "cat", FixmeHashLike hash] -> do
+        ha <- selectFixmeHash hash
+        notice $ pretty ha
+
       ReadFixmeStdin -> readFixmeStdin
 
       ListVal [SymbolVal "print-env"] -> do

fixme-new/lib/Fixme/State.hs

@@ -1,12 +1,16 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Fixme.State
   ( evolve
   , withState
   , insertFixme
+  , selectFixmeThin
+  , selectFixmeHash
   , selectFixme
   , insertCommit
   , selectCommit
   , newCommit
+  , HasPredicate(..)
   ) where
 
 import Fixme.Prelude
@@ -15,11 +19,43 @@ import Fixme.Config
 
 import HBS2.System.Dir
 import Data.Config.Suckless
+import Data.Config.Suckless.Syntax
 import DBPipe.SQLite
 
+import Data.Aeson as Aeson
 import Data.HashMap.Strict qualified as HM
 import Text.InterpolatedString.Perl6 (qc)
+import Data.Text qualified as Text
 import Data.Maybe
+import Data.Either
+import Data.List (sortBy,sortOn)
+import Data.Ord
+import Lens.Micro.Platform
+import Control.Monad.Trans.Maybe
+import Data.Coerce
+
+
+pattern Operand :: forall {c} . Text -> Syntax c
+pattern Operand what <- (operand -> Just what)
+
+pattern BinOp :: forall {c} . Id -> Syntax c
+pattern BinOp what <- (binOp -> Just what)
+
+binOp :: Syntax c -> Maybe Id
+binOp = \case
+  SymbolVal "~"  -> Just "like"
+  SymbolVal "&&" -> Just "and"
+  SymbolVal "||" -> Just "or"
+  _              -> Nothing
+
+operand :: Syntax c -> Maybe Text
+operand = \case
+  SymbolVal c -> Just (coerce c)
+  LitStrVal s -> Just s
+  LitIntVal i -> Just (Text.pack (show i))
+  LitScientificVal v -> Just (Text.pack (show v))
+  _ -> Nothing
+
 
 instance ToField HashRef where
   toField x = toField $ show $ pretty x
@@ -160,7 +196,14 @@ insertFixme fx@Fixme{..} = do
               |] (fxId, fixmeTs, "fixme-title", fixmeTitle)
 
 
-data SelectPredicate = All
+data SelectPredicate =
+    All
+  | FixmeHashExactly Text
+  | AttrLike Text Text
+  | And SelectPredicate SelectPredicate
+  | Or SelectPredicate SelectPredicate
+  | Ignored
+  deriving stock (Data,Generic,Show)
 
 class HasPredicate a where
   predicate :: a -> SelectPredicate
@@ -168,8 +211,135 @@ class HasPredicate a where
 instance HasPredicate () where
   predicate = const All
 
-selectFixme :: (FixmePerks m, HasPredicate a) => a -> FixmeM m [Fixme]
+instance HasPredicate SelectPredicate where
-selectFixme _ = do
+  predicate = id
-  pure mempty
+
+
+instance IsContext c => HasPredicate [Syntax c] where
+  predicate s = goPred $ unlist $ go s
+    where
+
+      goPred :: Syntax c -> SelectPredicate
+      goPred = \case
+        ListVal [SymbolVal "or", a, b]   ->  Or (goPred a) (goPred b)
+        ListVal [SymbolVal "and", a, b]  ->  And (goPred a) (goPred b)
+        ListVal [SymbolVal "like", StringLike a, StringLike b] ->  AttrLike (Text.pack a) (Text.pack b)
+        _ -> Ignored
+
+      go :: [Syntax c] -> Syntax c
+      go = \case
+
+        ( Operand a : SymbolVal "~" : Operand b  : rest ) -> do
+          go (mklist [mksym "like", mkstr a, mkstr b] : rest)
+
+        ( w : SymbolVal "&&" : rest ) -> do
+          mklist [mksym "and", unlist w, unlist (go rest)]
+
+        ( w : SymbolVal "||" : rest ) -> do
+          mklist [mksym "or", unlist w, unlist (go rest)]
+
+        w -> mklist w
+
+      unlist = \case
+        ListVal [x] -> x
+        x -> x
+
+      mklist = List (noContext :: Context c)
+      mksym  = Symbol (noContext :: Context c)
+      mkstr = Literal (noContext :: Context c) . LitStr
+
+{- HLINT ignore "Functor law" -}
+{- HLINT ignore "Eta reduce" -}
+
+selectFixmeHash :: (FixmePerks m) => Text -> FixmeM m (Maybe Text)
+selectFixmeHash what = withState do
+
+  r <- select @(Only Text) [qc|select id from fixme where id like ?|] (Only (what <> "%"))
+         <&> fmap fromOnly
+
+  pure $ catMaybes [ (x,) <$> Text.length . view _1 <$> Text.commonPrefixes what x | x <- r ]
+             & sortBy (comparing (Down . snd))
+             & headMay
+             & fmap fst
+
+
+selectFixme :: FixmePerks m => Text -> FixmeM m (Maybe Fixme)
+selectFixme txt = do
+  attrs <- selectFixmeThin (FixmeHashExactly txt)
+
+  runMaybeT do
+
+    self <- lift (withState $ select [qc|select blob from fixme where id = ? limit 1|] (Only txt))
+              <&> listToMaybe . fmap fromOnly
+              >>= toMPlus
+              <&> (deserialiseOrFail @Fixme)
+              >>= toMPlus
+
+    error "what"
+
+
+data Bound = forall a . (ToField a, Show a) => Bound a
+
+instance ToField Bound where
+  toField (Bound x) = toField x
+
+instance Show Bound where
+  show (Bound x) = show x
+
+genPredQ  :: Text -> SelectPredicate -> (Text, [Bound])
+genPredQ tbl what = go what
+  where
+    go = \case
+      All -> ("true", mempty)
+
+      FixmeHashExactly x ->
+        ([qc|({tbl}.fixme = ?)|], [Bound x])
+
+      AttrLike "fixme-hash" val -> do
+        let binds = [Bound (val <> "%")]
+        ([qc|({tbl}.fixme like ?)|], binds)
+
+      AttrLike name val -> do
+        let binds = [Bound name, Bound (val <> "%")]
+        ([qc|(exists (select null from fixmeattrview x where x.fixme = a.fixme and x.name = ? and x.value like ?))|], binds)
+
+
+      And a b -> do
+        let (asql, abound) = go a
+        let (bsql, bbound) = go b
+        ([qc|{asql} and {bsql}|], abound <> bbound)
+
+      Or a b -> do
+        let asql = go a
+        let bsql = go b
+        ([qc|{fst asql} or {fst bsql}|], snd asql <> snd bsql)
+
+      Ignored -> ("false", mempty)
+
+selectFixmeThin :: (FixmePerks m, HasPredicate a) => a -> FixmeM m [FixmeThin]
+selectFixmeThin a = withState do
+
+  let predic = genPredQ "a" (predicate a)
+
+  let sql = [qc|
+
+select
+  cast(json_set(json_group_object(a.name,a.value), '$."fixme-hash"', a.fixme) as blob)
+
+from
+  fixmeattrview a join fixme f on a.fixme = f.id
+
+where
+
+  {fst predic}
+
+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)
 
 

fixme-new/lib/Fixme/Types.hs

@@ -1,11 +1,17 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-module Fixme.Types where
+module Fixme.Types
+  ( module Fixme.Types
+  ) where
 
 import Fixme.Prelude
 
 import DBPipe.SQLite
 import HBS2.Git.Local
 
+import Data.Config.Suckless
+
+import Data.Aeson
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
 import Data.HashSet (HashSet)
@@ -13,10 +19,37 @@ import Data.HashSet qualified as HS
 import Data.Word (Word64,Word32)
 import Data.Maybe
 import Data.Coerce
+import Data.Text qualified as Text
 import System.FilePath
 import Text.InterpolatedString.Perl6 (qc)
 
 
+pattern StringLike :: forall {c} . String -> Syntax c
+pattern StringLike e <- (stringLike -> Just e)
+
+pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
+pattern StringLikeList e <- (stringLikeList -> e)
+
+pattern FixmeHashLike :: forall {c} . Text -> Syntax c
+pattern FixmeHashLike  e <- (fixmeHashFromSyn -> Just e)
+
+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
+  StringLike s -> do
+    let (_,value) = span (`elem` "#%~:") s
+    Just $ Text.pack value
+
+  _            -> Nothing
+
 newtype FixmeTag = FixmeTag { fromFixmeTag :: Text }
                    deriving newtype (Eq,Ord,Show,IsString,Hashable,Semigroup,Monoid,ToField,FromField)
                    deriving stock (Data,Generic)
@@ -31,12 +64,14 @@ newtype FixmePlainLine = FixmePlainLine { fromFixmeText :: Text }
 
 
 newtype FixmeAttrName = FixmeAttrName { fromFixmeAttrName :: Text }
-                        deriving newtype (Eq,Ord,Show,IsString,Hashable,ToField,FromField)
+                        deriving newtype (Eq,Ord,Show,IsString,Hashable)
+                        deriving newtype (ToField,FromField)
+                        deriving newtype (ToJSON,FromJSON,ToJSONKey,FromJSONKey)
                         deriving stock (Data,Generic)
 
 
 newtype FixmeAttrVal = FixmeAttrVal { fromFixmeAttrVal :: Text }
-                        deriving newtype (Eq,Ord,Show,IsString,Hashable,ToField,FromField)
+                        deriving newtype (Eq,Ord,Show,IsString,Hashable,ToField,FromField,ToJSON,FromJSON)
                         deriving stock (Data,Generic)
 
 newtype FixmeTimestamp = FixmeTimestamp Word64
@@ -61,6 +96,9 @@ data Fixme =
   }
   deriving stock (Show,Data,Generic)
 
+newtype FixmeThin = FixmeThin (HashMap FixmeAttrName FixmeAttrVal)
+                    deriving newtype (Semigroup,Monoid,Eq,Ord,Show,ToJSON,FromJSON)
+                    deriving stock (Data,Generic)
 
 type FixmePerks m = ( MonadUnliftIO m
                     , MonadIO m