Merge remote-tracking branch 'origin/master' into query

app/Main.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module Main where
 
 import Options.Applicative
@@ -10,20 +11,30 @@ import Data.Environment
 import UnliftIO.Directory
        (XdgDirectory(XdgData), getXdgDirectory)
 
+import Data.Foldable
+       (asum)
+
 import System.Environment
        (lookupEnv)
 
 import qualified Operations
 
+import Data.Query
+       (Field(..))
+
 commands :: Parser (BuukaM ())
 commands = subparser
-  (  command "insert" (info (insertOpts Operations.insert) (progDesc "Insert a new bookmark"))
+  (  command "insert" (info (insertOpts Operations.insert <**> helper) (progDesc "Insert a new bookmark"))
-  <> command "list" (info (pure Operations.list) (progDesc "List all the bookmarks"))
+  <> command "list" (info (pure Operations.list <**> helper) (progDesc "List all the bookmarks"))
+  <> command "query" (info (queryOpts Operations.query <**> helper) (progDesc "Query the bookmarks"))
   )
   where
     insertOpts f =
         f <$> strOption (long "url" <> short 'u' <> metavar "URL")
           <*> optional (strOption (long "title"))
+    queryOpts f =
+      uncurry f <$> asum [tagged Title "title", tagged Url "url"]
+    tagged t x = (t, ) <$> strOption (long x <> metavar "REGEX")
 
 main :: IO ()
 main = do

buuka.cabal

@@ -36,12 +36,15 @@ library
   exposed-modules:     MyLib
                      , Database.Migrations
                      , Control.Monad.Buuka
+                     , Operations.Format
                      , Operations.Insert
                      , Operations.List
-                     , Operations.Format
+                     , Operations.Query
                      , Operations
                      , Data.Environment
                      , Data.Buuka
+                     , Data.Query
+                     , Data.Functor.Foldable
   -- other-modules:
   build-depends:       aeson
                      , yaml
@@ -57,6 +60,7 @@ library
                      , text
                      , lens
                      , hashable
+                     , regex-tdfa
   hs-source-dirs:      src
 
 executable buuka
@@ -73,6 +77,8 @@ test-suite buuka-test
   import:              common-stanza
   other-modules:       Test.Database.Migrations
                        Test.Data.Buuka
+                       Test.Data.Query
+                       Test.Data.Functor.Foldable
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test
   main-is:             MyLibTest.hs
@@ -80,6 +86,8 @@ test-suite buuka-test
                      , hedgehog
                      , hedgehog-corpus
                      , tasty-hedgehog
+                     , tasty-hunit
                      , tasty
                      , text
                      , aeson
+                     , deriving-compat

default.nix

@@ -1,6 +1,7 @@
-{ mkDerivation, aeson, base, bytestring, containers, exceptions
+{ mkDerivation, aeson, base, bytestring, containers
-, filepath, hashable, hashids, hedgehog, hedgehog-corpus, lens, mtl
+, deriving-compat, exceptions, filepath, hashable, hashids
-, optparse-applicative, stdenv, tasty, tasty-hedgehog, text
+, hedgehog, hedgehog-corpus, lens, mtl, optparse-applicative
+, regex-tdfa, stdenv, tasty, tasty-hedgehog, tasty-hunit, text
 , transformers, unliftio, vector, yaml
 }:
 mkDerivation {
@@ -11,11 +12,12 @@ mkDerivation {
   isExecutable = true;
   libraryHaskellDepends = [
     aeson base bytestring containers exceptions filepath hashable
-    hashids lens mtl text transformers unliftio vector yaml
+    hashids lens mtl regex-tdfa text transformers unliftio vector yaml
   ];
   executableHaskellDepends = [ base optparse-applicative unliftio ];
   testHaskellDepends = [
-    aeson base hedgehog hedgehog-corpus tasty tasty-hedgehog text
+    aeson base deriving-compat hedgehog hedgehog-corpus tasty
+    tasty-hedgehog tasty-hunit text
   ];
   license = stdenv.lib.licenses.bsd3;
 }

src/Data/Functor/Foldable.hs

@@ -0,0 +1,44 @@
+{-|
+Module      : Data.Functor.Foldable
+Description : Simplified recursion schemes
+Copyright   : (c) Mats Rauhala, 2020
+License     : BSD-3-Clause
+Maintainer  : mats.rauhala@iki.fi
+Stability   : experimental
+Portability : POSIX
+
+Simplified recursion schemes, providing only the minimal schemes
+-}
+module Data.Functor.Foldable
+  ( Fix(..)
+  , cata
+  , ana
+  , hylo
+  )
+  where
+
+import Data.Functor.Classes
+
+newtype Fix f = Fix { getFix :: f (Fix f) }
+
+instance Show1 f => Show (Fix f) where
+  showsPrec d (Fix f) = showString "Fix " . showsPrec1 d f
+
+instance Eq1 f => Eq (Fix f) where
+  (Fix a) == (Fix b) = liftEq (==) a b
+
+-- | Catamorphism or the fold
+--
+-- Fold a recursive structure into a value
+cata :: Functor f => (f a -> a) -> Fix f -> a
+cata f = a where a = f . fmap a . getFix
+
+-- | Anamorphism or the unfold
+--
+-- Unfold a seed into a recursive structure
+ana :: Functor f => (a -> f a) -> a -> Fix f
+ana f = a where a = Fix . fmap a . f
+
+-- | Combined fold and unfold
+hylo :: (Functor f) => (f a -> a) -> (b -> f b) -> b -> a
+hylo f u = a where a = f . fmap a . u

src/Data/Query.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+module Data.Query
+  (
+    -- * AST
+    Field(..)
+
+    -- * Combinators
+  , startsWith
+  , endsWith
+  , regex
+  , (.&&.)
+
+    -- * Evaluating queries
+  , evaluate
+  , predicate
+  )
+  where
+
+import Data.Buuka
+       (BuukaEntry(..), URL(..))
+
+import Data.List
+       (isPrefixOf, isSuffixOf)
+
+import Text.Regex.TDFA
+       ((=~))
+
+import Data.Functor.Foldable
+       (Fix(..), cata)
+
+data Field a where
+  Url :: Field String
+  Title :: Field String
+
+data QueryF f where
+  StartsWith :: Field String -> String -> QueryF f
+  EndsWith :: Field String -> String -> QueryF f
+  Regex :: Field String -> String -> QueryF f
+  And :: f -> f -> QueryF f
+
+deriving instance Functor QueryF
+
+type Query = Fix QueryF
+
+startsWith :: Field String -> String -> Query
+startsWith field x = Fix (StartsWith field x)
+
+endsWith :: Field String -> String -> Query
+endsWith field x = Fix (EndsWith field x)
+
+regex :: Field String -> String -> Query
+regex field x = Fix (Regex field x)
+
+(.&&.) :: Query -> Query -> Query
+a .&&. b = Fix (And a b)
+
+evaluate :: QueryF (BuukaEntry -> Bool) -> (BuukaEntry -> Bool)
+evaluate = \case
+  StartsWith Url x -> \BuukaEntry{url=URL u} -> x `isPrefixOf` u
+  EndsWith Url x -> \BuukaEntry{url=URL u} -> x `isSuffixOf` u
+  StartsWith Title x -> \BuukaEntry{title=t} -> maybe False (x `isPrefixOf`) t
+  EndsWith Title x -> \BuukaEntry{title=t} -> maybe False (x `isSuffixOf`) t
+  Regex Url x -> \BuukaEntry{url=URL u} -> u =~ x
+  Regex Title x -> \BuukaEntry{title=t} -> maybe False (=~ x) t
+  And a b -> \e -> a e && b e
+
+predicate :: Query -> BuukaEntry -> Bool
+predicate = cata evaluate

src/Operations.hs

@@ -1,6 +1,7 @@
 module Operations
   ( module Operations.Insert
   , module Operations.List
+  , module Operations.Query
   )
   where
 
@@ -8,3 +9,5 @@ import Operations.Insert
        (insert)
 import Operations.List
        (list)
+import Operations.Query
+       (query)

src/Operations/Query.hs

@@ -0,0 +1,23 @@
+module Operations.Query where
+
+import Data.Query
+
+import Control.Monad.Buuka
+import Control.Monad.Reader
+
+import Data.Foldable
+       (traverse_)
+
+import Data.Buuka
+       (Buuka)
+import qualified Data.Buuka as B
+
+import Operations.Format
+
+query :: Field String -> String -> BuukaM ()
+query field q =
+  buukaQ (asks go) >>= traverse_ (liftIO . putStrLn)
+  where
+    go :: Buuka -> [String]
+    go b = formatEntries b (filter (predicate (regex field q)) . B.elements $ b)
+

test/MyLibTest.hs

@@ -3,12 +3,16 @@ module Main (main) where
 import Test.Tasty
 
 import qualified Test.Data.Buuka as Data.Buuka
+import qualified Test.Data.Query as Data.Query
+import qualified Test.Data.Functor.Foldable as Data.Functor.Foldable
 import qualified Test.Database.Migrations as Database.Migrations
 
 tests :: TestTree
 tests = testGroup "buuka"
   [ Database.Migrations.tests
   , Data.Buuka.tests
+  , Data.Functor.Foldable.tests
+  , Data.Query.tests
   ]
 
 main :: IO ()

test/Test/Data/Functor/Foldable.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Test.Data.Functor.Foldable where
+
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import Test.Tasty
+import Test.Tasty.Hedgehog
+
+import Data.Eq.Deriving
+       (deriveEq1)
+import Text.Show.Deriving
+       (deriveShow1)
+
+import Data.Functor.Foldable
+
+data AST f
+  = Addition f f
+  | Value Int
+  deriving stock (Functor, Eq, Show)
+
+deriveShow1 ''AST
+deriveEq1 ''AST
+
+evaluate :: AST Int -> Int
+evaluate = \case
+  Addition a b -> a + b
+  Value x -> x
+
+render :: AST String -> String
+render = \case
+  Addition a b -> a <> " + " <> b
+  Value x -> show x
+
+parse :: [String] -> AST [String]
+parse = \case
+  a : "+" : b : xs -> Addition (a : xs) [b]
+  [a] -> Value (read a)
+  _ -> Value 0
+
+genAST :: Gen (Fix AST)
+genAST = Gen.recursive Gen.choice
+  [ Fix . Value <$> Gen.integral (Range.linear 0 100) ]
+  [ Gen.subterm2 genAST genAST (\a b -> Fix (Addition a b))
+  ]
+
+prop_parse_render_tripping :: Property
+prop_parse_render_tripping = property $ do
+  x <- forAll genAST
+  let rendered = cata render x
+      parsed = ana parse . words $ rendered
+  annotateShow rendered
+  annotateShow parsed
+  annotateShow $ cata evaluate x
+  cata evaluate parsed === cata evaluate x
+
+prop_parse_render_hylo :: Property
+prop_parse_render_hylo = property $ do
+  x <- forAll genAST
+  let rendered = cata render x
+  hylo evaluate parse (words rendered) === cata evaluate x
+
+tests :: TestTree
+tests = testGroup "Data.Functor.Foldable"
+  [ testProperty "cata and ana do reverse" $ prop_parse_render_tripping
+  , testProperty "hylo do reverse" $ prop_parse_render_hylo
+  ]

test/Test/Data/Query.hs

@@ -0,0 +1,39 @@
+module Test.Data.Query where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Data.Buuka
+       (BuukaEntry(..), URL(..))
+import Data.Functor.Foldable
+       (cata)
+import Data.Query
+
+test_startswith :: Assertion
+test_startswith = do
+  let entry = BuukaEntry (URL "http://example.com") (Just "foo")
+  cata evaluate (startsWith Url "http://") entry @?= True
+  cata evaluate (startsWith Url "https://") entry @?= False
+  cata evaluate (startsWith Title "foo") entry @?= True
+  cata evaluate (startsWith Title "bar") entry @?= False
+
+test_endswith :: Assertion
+test_endswith = do
+  let entry = BuukaEntry (URL "http://example.com") (Just "foo")
+  cata evaluate (endsWith Url "com") entry @?= True
+  cata evaluate (endsWith Url "fi") entry @?= False
+  cata evaluate (endsWith Title "foo") entry @?= True
+  cata evaluate (endsWith Title "bar") entry @?= False
+
+test_and :: Assertion
+test_and = do
+  let entry = BuukaEntry (URL "http://example.com") (Just "foo")
+  cata evaluate (startsWith Url "http://" .&&. endsWith Url ".com") entry @?= True
+  cata evaluate (startsWith Url "http://" .&&. endsWith Url ".fi") entry @?= False
+
+tests :: TestTree
+tests = testGroup "Data.Query"
+  [ testCase "Queries startsWith" test_startswith
+  , testCase "Queries endsWith" test_endswith
+  , testCase "Queries and" test_and
+  ]