From 8e57921a1b2fd4b43f7becc42bc11710ab3a1ebb Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Wed, 27 Oct 2021 20:46:23 +0300 Subject: [PATCH] Bump versions and multiple queries --- app/Main.hs | 3 ++- buuka.cabal | 2 +- default.nix | 6 +++--- shell.nix | 18 +++++++++++++----- src/Data/Buuka.hs | 13 +++++++++++-- src/Data/Query.hs | 24 ++++++++++++++++++++---- src/Operations/Import/Firefox.hs | 6 +++--- src/Operations/Query.hs | 8 +++++--- 8 files changed, 58 insertions(+), 22 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 662dec2..5b00668 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -21,6 +21,7 @@ import qualified Operations import Data.Query (Field(..)) +import qualified Options.Applicative.NonEmpty as NE commands :: Parser (BuukaM ()) commands = subparser @@ -34,7 +35,7 @@ commands = subparser f <$> strOption (long "url" <> short 'u' <> metavar "URL") <*> optional (strOption (long "title")) queryOpts f = - uncurry f <$> asum [tagged Title "title", tagged Url "url"] + f <$> NE.some1 (asum [tagged Title "title", tagged Url "url"]) tagged t x = (t, ) <$> strOption (long x <> metavar "REGEX") main :: IO () diff --git a/buuka.cabal b/buuka.cabal index c4d48b2..3fdbe4b 100644 --- a/buuka.cabal +++ b/buuka.cabal @@ -16,7 +16,7 @@ category: Web extra-source-files: CHANGELOG.md common common-stanza - build-depends: base ^>=4.13.0.0 + build-depends: base >=4.13.0.0 && <4.15 default-extensions: OverloadedStrings , ScopedTypeVariables , DerivingVia diff --git a/default.nix b/default.nix index ece3a3d..d77232a 100644 --- a/default.nix +++ b/default.nix @@ -1,7 +1,7 @@ { mkDerivation, aeson, base, bytestring, conduit, conduit-extra , containers, deriving-compat, exceptions, filepath, hashable -, hashids, hedgehog, hedgehog-corpus, lens, mtl -, optparse-applicative, regex-tdfa, sqlite-simple, stdenv, tasty +, hashids, hedgehog, hedgehog-corpus, lens, lib, mtl +, optparse-applicative, regex-tdfa, sqlite-simple, tasty , tasty-hedgehog, tasty-hunit, text, transformers, unliftio, vector , yaml }: @@ -21,5 +21,5 @@ mkDerivation { aeson base deriving-compat hedgehog hedgehog-corpus tasty tasty-hedgehog tasty-hunit text ]; - license = stdenv.lib.licenses.bsd3; + license = lib.licenses.bsd3; } diff --git a/shell.nix b/shell.nix index 96c698f..c1f11f1 100644 --- a/shell.nix +++ b/shell.nix @@ -1,18 +1,26 @@ with (import {}); let - buuka = haskellPackages.callPackage ./. {}; + hp = haskellPackages.extend (self: super: { + buuka = haskellPackages.callPackage ./. {}; + }); + easy-hls-src = fetchFromGitHub { + owner = "ssbothwell"; + repo = "easy-hls-nix"; + inherit (builtins.fromJSON (builtins.readFile ./easy-hls-nix.json)) rev sha256; + }; + easy-hls = callPackage easy-hls-src { ghcVersions = [ hp.ghc.version ]; }; in -mkShell { - name = "shell-buuka"; +hp.shellFor { + packages = h: [h.buuka]; buildInputs = [ hlint ghcid stylish-haskell cabal2nix - haskellPackages.cabal-install - (haskellPackages.ghcWithHoogle (_: buuka.buildInputs ++ buuka.propagatedBuildInputs)) + cabal-install + easy-hls ]; } diff --git a/src/Data/Buuka.hs b/src/Data/Buuka.hs index fc1d9c2..c7cfbc0 100644 --- a/src/Data/Buuka.hs +++ b/src/Data/Buuka.hs @@ -30,7 +30,7 @@ import Data.Hashable import GHC.Generics (Generic) -import Data.Text +import Data.Text (Text) import Control.Monad.Reader import Control.Monad.State @@ -51,7 +51,16 @@ data BuukaEntry , _title :: Maybe Text } deriving stock (Show, Eq, Generic) - deriving anyclass (ToJSON, FromJSON, Hashable) + deriving anyclass (Hashable) + +opts :: Options +opts = defaultOptions { fieldLabelModifier = dropWhile (== '_'), omitNothingFields = True } + +instance ToJSON BuukaEntry where + toJSON = genericToJSON opts + +instance FromJSON BuukaEntry where + parseJSON = genericParseJSON opts makeLenses ''BuukaEntry diff --git a/src/Data/Query.hs b/src/Data/Query.hs index 4425caa..d9f743f 100644 --- a/src/Data/Query.hs +++ b/src/Data/Query.hs @@ -1,5 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module Data.Query ( -- * AST @@ -41,11 +43,20 @@ data QueryF f where EndsWith :: Field Text -> Text -> QueryF f Regex :: Field Text -> Text -> QueryF f And :: f -> f -> QueryF f + Pass :: QueryF f deriving instance Functor QueryF type Query = Fix QueryF +-- Query is a semigroup over the && +instance Semigroup Query where + (<>) = (.&&.) + +-- Identity is the constant true +instance Monoid Query where + mempty = Fix Pass + startsWith :: Field Text -> Text -> Query startsWith field x = Fix (StartsWith field x) @@ -60,13 +71,18 @@ a .&&. b = Fix (And a b) evaluate :: QueryF (BuukaEntry -> Bool) -> (BuukaEntry -> Bool) evaluate = \case - StartsWith Url x -> \e -> x `T.isPrefixOf` (e ^. url . _URL) - EndsWith Url x -> \e -> x `T.isSuffixOf` (e ^. url . _URL) - StartsWith Title x -> \e -> maybe False (x `T.isPrefixOf`) $ e ^. title - EndsWith Title x -> \e -> maybe False (x `T.isSuffixOf`) $ e ^. title + StartsWith Url x -> has (url . _URL . prefixed x) + EndsWith Url x -> has (url . _URL . suffixed x) + StartsWith Title x -> has (title . _Just . prefixed x) + EndsWith Title x -> has (title . _Just . suffixed x) Regex Url x -> \e -> (e ^. url . _URL) =~ x Regex Title x -> \e -> maybe False (=~ x) $ e ^. title And a b -> \e -> a e && b e + Pass -> const True + where + prefixed ps = prism' (ps <>) (T.stripPrefix ps) + suffixed qs = prism' (<> qs) (T.stripSuffix qs) predicate :: Query -> BuukaEntry -> Bool predicate = cata evaluate + diff --git a/src/Operations/Import/Firefox.hs b/src/Operations/Import/Firefox.hs index 0c86d7a..69d9faa 100644 --- a/src/Operations/Import/Firefox.hs +++ b/src/Operations/Import/Firefox.hs @@ -79,7 +79,7 @@ newtype ImportException data Firefox = Firefox { _url :: Text - , _title :: Text + , _title :: Maybe Text , _keywords :: [Text] } deriving stock (Show, Eq) @@ -124,9 +124,9 @@ importFirefox = do -- exist in the set, will it be inserted to the store buukaU $ modify $ \oldState -> F.foldl' update (initialState oldState) fs ^. buuka where - toEntry Firefox{..} = B.BuukaEntry{ B._url = B.URL _url, B._title = Just _title } + toEntry Firefox{..} = B.BuukaEntry{ B._url = B.URL _url, B._title = _title } update acc f = acc & seen <>~ (f ^. url . to S.singleton) - & if has (seen . ix (f ^. url)) acc then id else buuka %~ (B.insert (toEntry f)) + & if has (seen . ix (f ^. url)) acc then id else buuka %~ B.insert (toEntry f) initialState oldState = Update oldState (initialUrls oldState) initialUrls = foldMapOf (B._Buuka . folded . B.url . B._URL) S.singleton diff --git a/src/Operations/Query.hs b/src/Operations/Query.hs index d871181..19d8b77 100644 --- a/src/Operations/Query.hs +++ b/src/Operations/Query.hs @@ -17,11 +17,13 @@ import Operations.Format import Data.Text (Text) import qualified Data.Text.IO as T +import Data.List.NonEmpty (NonEmpty) -query :: Field Text -> Text -> BuukaM () -query field q = +query :: NonEmpty (Field Text, Text) -> BuukaM () +query qs = buukaQ (asks go) >>= traverse_ (liftIO . T.putStrLn) where + q = foldMap (uncurry regex) qs go :: Buuka -> [Text] - go b = formatEntries b (filter (predicate (regex field q)) . B.elements $ b) + go b = formatEntries b (filter (predicate q) . B.elements $ b)