From b06ca3c3f5f9cd9e258addccadac6adecbf3dabd Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sun, 12 May 2024 15:54:06 +0300 Subject: [PATCH] wip --- fixme-new/fixme.cabal | 2 + fixme-new/lib/Fixme/Run.hs | 35 ++++--- fixme-new/lib/Fixme/State.hs | 178 ++++++++++++++++++++++++++++++++++- fixme-new/lib/Fixme/Types.hs | 44 ++++++++- 4 files changed, 234 insertions(+), 25 deletions(-) diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index df576fd3..e1575023 100644 --- a/fixme-new/fixme.cabal +++ b/fixme-new/fixme.cabal @@ -61,6 +61,8 @@ common shared-properties , suckless-conf , fuzzy-parse + , aeson + , aeson-pretty , attoparsec , atomic-write , bytestring diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 15130607..77f23c0b 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/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 = do - fixmies <- selectFixme () - pure () +list_ :: (FixmePerks m, HasPredicate a) => a -> FixmeM m () +list_ a = do + fixmies <- selectFixmeThin a + 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 diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index 823b9b18..9a3a42d1 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/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] -selectFixme _ = do - pure mempty +instance HasPredicate SelectPredicate where + predicate = id + + +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) diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 7eb77969..de18dc55 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/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