Bump versions and multiple queries

This commit is contained in:
Mats Rauhala 2021-10-27 20:46:23 +03:00
parent eb16640f41
commit 8e57921a1b
8 changed files with 58 additions and 22 deletions

View File

@ -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 ()

View File

@ -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

View File

@ -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;
}

View File

@ -1,18 +1,26 @@
with (import <nixpkgs> {});
let
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
];
}

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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)