Initial query AST

buuka.cabal

@@ -42,6 +42,8 @@ library
                      , Operations
                      , Data.Environment
                      , Data.Buuka
+                     , Data.Query
+                     , Data.Functor.Foldable
   -- other-modules:
   build-depends:       aeson
                      , yaml
@@ -73,6 +75,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

src/Data/Functor/Foldable.hs

@@ -0,0 +1,36 @@
+{-|
+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
+
+newtype Fix f = Fix { getFix :: f (Fix f) }
+
+-- | 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,52 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+module Data.Query
+  (
+    -- * Combinators
+    startsWith
+  , endsWith
+  , (.&&.)
+
+    -- * Evaluating queries
+  , evaluate
+  )
+  where
+
+import Data.Buuka
+       (BuukaEntry(..), URL(..))
+
+import Data.List
+       (isPrefixOf, isSuffixOf)
+
+import Data.Functor.Foldable
+       (Fix(..))
+
+data Field a where
+  Url :: Field String
+  Title :: Field String
+
+data QueryF f
+  = forall a. StartsWith (Field a) a
+  | forall a. EndsWith (Field a) a
+  | And f f
+
+deriving instance Functor QueryF
+
+type Query = Fix QueryF
+
+startsWith :: Field a -> a -> Query
+startsWith field x = Fix (StartsWith field x)
+
+endsWith :: Field a -> a -> Query
+endsWith field x = Fix (EndsWith 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
+  And a b -> \e -> a e && b e

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,6 @@
+module Test.Data.Functor.Foldable where
+
+import Test.Tasty
+
+tests :: TestTree
+tests = testGroup "Data.Functor.Foldable" []

test/Test/Data/Query.hs

@@ -0,0 +1,6 @@
+module Test.Data.Query where
+
+import Test.Tasty
+
+tests :: TestTree
+tests = testGroup "Data.Query" []