89 lines
1.9 KiB
Haskell
89 lines
1.9 KiB
Haskell
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
module Data.Query
|
|
(
|
|
-- * AST
|
|
Field(..)
|
|
|
|
-- * Combinators
|
|
, startsWith
|
|
, endsWith
|
|
, regex
|
|
, (.&&.)
|
|
|
|
-- * Evaluating queries
|
|
, evaluate
|
|
, predicate
|
|
)
|
|
where
|
|
|
|
import Data.Buuka
|
|
(BuukaEntry, title, url, _URL)
|
|
|
|
import Control.Lens
|
|
|
|
import Text.Regex.TDFA
|
|
((=~))
|
|
|
|
import Data.Functor.Foldable
|
|
(Fix(..), cata)
|
|
|
|
import Data.Text
|
|
(Text)
|
|
import qualified Data.Text as T
|
|
|
|
data Field a where
|
|
Url :: Field Text
|
|
Title :: Field Text
|
|
|
|
data QueryF f where
|
|
StartsWith :: Field Text -> Text -> QueryF f
|
|
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)
|
|
|
|
endsWith :: Field Text -> Text -> Query
|
|
endsWith field x = Fix (EndsWith field x)
|
|
|
|
regex :: Field Text -> Text -> 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 -> 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
|
|
|