buuka/src/Data/Query.hs

{-# 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