diff --git a/buuka.cabal b/buuka.cabal index 1e676b2..29280b0 100644 --- a/buuka.cabal +++ b/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 diff --git a/src/Data/Functor/Foldable.hs b/src/Data/Functor/Foldable.hs new file mode 100644 index 0000000..86fb7f1 --- /dev/null +++ b/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 diff --git a/src/Data/Query.hs b/src/Data/Query.hs new file mode 100644 index 0000000..47a925f --- /dev/null +++ b/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 diff --git a/test/MyLibTest.hs b/test/MyLibTest.hs index 306f4d7..275f067 100644 --- a/test/MyLibTest.hs +++ 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 () diff --git a/test/Test/Data/Functor/Foldable.hs b/test/Test/Data/Functor/Foldable.hs new file mode 100644 index 0000000..56f3c41 --- /dev/null +++ b/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" [] diff --git a/test/Test/Data/Query.hs b/test/Test/Data/Query.hs new file mode 100644 index 0000000..4f8bd12 --- /dev/null +++ b/test/Test/Data/Query.hs @@ -0,0 +1,6 @@ +module Test.Data.Query where + +import Test.Tasty + +tests :: TestTree +tests = testGroup "Data.Query" []