Initial query AST

This commit is contained in:
Mats Rauhala 2021-01-02 09:09:38 +02:00
parent e802f66599
commit 55188f514f
6 changed files with 108 additions and 0 deletions

View File

@ -42,6 +42,8 @@ library
, Operations , Operations
, Data.Environment , Data.Environment
, Data.Buuka , Data.Buuka
, Data.Query
, Data.Functor.Foldable
-- other-modules: -- other-modules:
build-depends: aeson build-depends: aeson
, yaml , yaml
@ -73,6 +75,8 @@ test-suite buuka-test
import: common-stanza import: common-stanza
other-modules: Test.Database.Migrations other-modules: Test.Database.Migrations
Test.Data.Buuka Test.Data.Buuka
Test.Data.Query
Test.Data.Functor.Foldable
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
hs-source-dirs: test hs-source-dirs: test
main-is: MyLibTest.hs main-is: MyLibTest.hs

View File

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

52
src/Data/Query.hs Normal file
View File

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

View File

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

View File

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

6
test/Test/Data/Query.hs Normal file
View File

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