Bump versions and multiple queries

Reviewed-on: #1

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

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

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

shell.nix

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

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
 

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
+

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

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)