diff --git a/google-search.cabal b/google-search.cabal --- a/google-search.cabal +++ b/google-search.cabal @@ -1,5 +1,5 @@ name: google-search -version: 0.0.1.0 +version: 0.1.0.0 synopsis: EDSL for Google and GMail search expressions description: Construct well-typed search expressions for use in various Google services. diff --git a/src/Language/Google/Search/Mail.hs b/src/Language/Google/Search/Mail.hs --- a/src/Language/Google/Search/Mail.hs +++ b/src/Language/Google/Search/Mail.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -100,12 +99,12 @@ instance SearchBuilder MailOp where searchBuilder operator = case operator of - Plain s -> searchBuilder s - From s -> "from:" <> searchBuilder s - To s -> "to:" <> searchBuilder s - Subject s -> "subject:" <> searchBuilder s - Label t -> "label:" <> B.fromText t - Has ft -> "has:" <> case ft of + Plain s -> searchBuilder s + From s -> "from:" <>? s + To s -> "to:" <>? s + Subject s -> "subject:" <>? s + Label t -> "label:" <>! B.fromText t + Has ft -> "has:" <>! case ft of Attachment -> "attachment" BlueInfo -> "blue-info" BlueStar -> "blue-star" @@ -122,38 +121,46 @@ UserLabels -> "userlabels" YellowBang -> "yellow-bang" YellowStar -> "yellow-star" - List s -> "list:" <> searchBuilder s - Filename s -> "filename:" <> searchBuilder s - In l -> "in:" <> case l of + List s -> "list:" <>? s + Filename s -> "filename:" <>? s + In l -> "in:" <>! case l of Anywhere -> "anywhere" Inbox -> "inbox" Trash -> "trash" Spam -> "spam" - Is s -> "is:" <> case s of + Is s -> "is:" <>! case s of Important -> "important" Starred -> "starred" Unread -> "unread" Read -> "read" Chat -> "chat" - Cc s -> "cc:" <> searchBuilder s - Bcc s -> "bcc:" <> searchBuilder s - After d -> "after:" <> date d - Before d -> "before:" <> date d - Older n d -> "older_than:" <> duration n d - Newer n d -> "newer_than:" <> duration n d - DeliveredTo s -> "deliveredto:" <> searchBuilder s - FromCircle s -> "circle:" <> searchBuilder s - Category c -> "category:" <> case c of + Cc s -> "cc:" <>? s + Bcc s -> "bcc:" <>? s + After d -> "after:" <>! date d + Before d -> "before:" <>! date d + Older n d -> "older_than:" <>! duration n d + Newer n d -> "newer_than:" <>! duration n d + DeliveredTo s -> "deliveredto:" <>? s + FromCircle s -> "circle:" <>? s + Category c -> "category:" <>! case c of Forums -> "forums" Personal -> "personal" Promotions -> "promotions" Social -> "social" Updates -> "updates" - Larger n u -> "larger:" <> size n u - Smaller n u -> "smaller:" <> size n u - RFC822MsgId t -> "rfc822msgid:" <> B.fromText t + Larger n u -> "larger:" <>! size n u + Smaller n u -> "smaller:" <>! size n u + RFC822MsgId t -> "rfc822msgid:" <>! B.fromText t where + infix 6 <>?, <>! + + (<>?) :: (SearchBuilder e) => Builder -> e -> PrecBuilder + name <>? arg = parentheses 10 $ \ p -> name <> p (searchBuilder arg) + + (<>!) :: Builder -> Builder -> PrecBuilder + name <>! arg = PrecBuilder 10 (name <> arg) + date :: Day -> Builder date = B.fromString . formatTime defaultTimeLocale "%Y/%m/%d" diff --git a/src/Language/Google/Search/Simple.hs b/src/Language/Google/Search/Simple.hs --- a/src/Language/Google/Search/Simple.hs +++ b/src/Language/Google/Search/Simple.hs @@ -1,15 +1,20 @@ {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | An orphan lives in this module, +-- +-- @ +-- instance ('Functor' f, 'IsString' a) => 'IsString' ('Free' f a) +-- @ +-- +-- so that we can write @\"simple queries\" :: 'Simple'@. + module Language.Google.Search.Simple where import Prelude import Control.Monad.Free import Data.Char (isSpace) -import Data.Foldable (fold) -import Data.List (intersperse) import Data.Monoid import Data.String (IsString (..)) import Data.Text (Text) @@ -17,68 +22,125 @@ import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as B +instance (Functor f, IsString a) => IsString (Free f a) where + fromString = return . fromString + +------------------------------------------------------------------------ -- * Units data Duration = Days | Months | Years deriving (Show) data Size = Bytes | KBytes | MBytes deriving (Show) +------------------------------------------------------------------------ +-- * Search expression construction + +-- | 'Builder' with precedence, though ambiguous associativity. +-- (But that's okay because Google doesn't mind which way you lean.) +-- +-- Note that at Google @OR@ binds tighter than conjunction, which is flipped +-- in contrast to everywhere else. We take the analogous Haskell fixities +-- when building search expressions: +-- +-- * 11: atomic tokens or parenthesised expressions +-- +-- * 10: complementation, search operators (cf. Haskell prefix application) +-- +-- * 3: disjunction (@OR@ or @|@) +-- +-- * 2: conjunction (by juxtaposition) +data PrecBuilder = PrecBuilder Int Builder deriving (Show) + +-- | Give me the precedence of the piece of syntax you're building, and I'll +-- give you a function that parenthesise any sub-expressions when necessary. +parentheses :: Int -> + ((PrecBuilder -> Builder) -> Builder) -> PrecBuilder +parentheses outer f = PrecBuilder outer . f $ \ (PrecBuilder inner e) -> + if outer > inner then "(" <> e <> ")" else e + -- | Render a search expression using Google search syntax. class SearchBuilder e where - searchBuilder :: e -> Builder + searchBuilder :: e -> PrecBuilder +-- | Higher-order version of 'SearchBuilder'. +class SyntaxBuilder f where + syntaxBuilder :: f PrecBuilder -> PrecBuilder + -- | 'SearchBuilder' for 'Free'! -instance (Functor f, SearchBuilder a, SearchBuilder (f Builder)) => +instance (Functor f, SearchBuilder a, SyntaxBuilder f) => SearchBuilder (Free f a) where - searchBuilder = iter searchBuilder . fmap searchBuilder + searchBuilder = iter syntaxBuilder . fmap searchBuilder ------------------------------------------------------------------------ +-- * Generalised Boolean operators + +infixr 2 \/ +class DisjunctF f where disjunctF :: e -> e -> f e +class Disjunct e where (\/) :: e -> e -> e +instance (DisjunctF f) => Disjunct (Free f a) where + a \/ b = Free (disjunctF a b) + +infixr 3 /\ +class ConjunctF f where conjunctF :: e -> e -> f e +class Conjunct e where (/\) :: e -> e -> e +instance (ConjunctF f) => Conjunct (Free f a) where + a /\ b = Free (conjunctF a b) + +class ComplementF f where complementF :: e -> f e +class Complement e where notB :: e -> e +instance (ComplementF f) => Complement (Free f a) where + notB = Free . complementF + +-- | 'andB' is to '/\' what 'and' is to '&&'. +andB :: (Conjunct e) => [e] -> e +andB = foldr1 (/\) + +-- | 'orB' is to '\/' what 'or' is to '||'. +orB :: (Conjunct e) => [e] -> e +orB = foldr1 (/\) + +------------------------------------------------------------------------ -- * Primitive Terms -- | 'Fuzzy' terms are grouped with parentheses (if necessary), while -- 'Exact' terms are always “double-quoted”. The 'IsString' instance --- defaults to 'Fuzzy', so a @\"literal string\" ∷ 'Term'@ may be used. -data Term = Fuzzy Text | Exact Text deriving (Show) -instance IsString Term where fromString = Fuzzy . T.pack +-- defaults to 'Fuzzy', so just writing @\"literal string\" ∷ 'Term' 'Text'@ +-- is acceptable. +data Term t = Fuzzy t | Exact t deriving (Functor, Show) +instance (IsString t) => IsString (Term t) where fromString = Fuzzy . fromString -instance SearchBuilder Term where - searchBuilder term = case term of - Fuzzy s -> ($ B.fromText s) $ - if T.any isSpace s then ("(" <>) . (<> ")") else id - Exact s -> ($ B.fromText s) $ - (B.singleton '"' <>) . (<> B.singleton '"') +instance SearchBuilder Text where + searchBuilder t = PrecBuilder prec (B.fromText t) where + prec = if T.any isSpace t then 2 else 11 +instance SyntaxBuilder Term where + syntaxBuilder term = case term of + Fuzzy e -> e + Exact (PrecBuilder _ e) -> PrecBuilder 11 $ "\"" <> e <> "\"" + +instance (SearchBuilder a) => SearchBuilder (Term a) where + searchBuilder = syntaxBuilder . fmap searchBuilder + ------------------------------------------------------------------------ +-- * Boolean expressions -- | The shape of Boolean expressions. -data BooleanF e = Not e | And [e] | Or [e] deriving (Functor, Show) +infixr 3 `AndB` +infixr 2 `OrB` +data BooleanF e = NotB e | e `AndB` e | e `OrB` e deriving (Functor, Show) -instance SearchBuilder (BooleanF Builder) where - searchBuilder b = case b of - Not e -> "-" <> e - And es -> ("(" <>) . (<> ")") . fold $ intersperse " " es - Or es -> ("(" <>) . (<> ")") . fold $ intersperse " OR " es +instance ConjunctF BooleanF where conjunctF = AndB +instance DisjunctF BooleanF where disjunctF = OrB +instance ComplementF BooleanF where complementF = NotB --- | The free Boolean-shaped monad: comes with an 'IsString' instance --- so we can write @\"simple queries\" :: 'Simple'@. No refunds. -type BooleanM = Free BooleanF +instance SyntaxBuilder BooleanF where + syntaxBuilder bool = case bool of + NotB e -> parentheses 10 $ \ p -> "-" <> p e + a `AndB` b -> parentheses 2 $ \ p -> p a <> " " <> p b + a `OrB` b -> parentheses 3 $ \ p -> p a <> " OR " <> p b -instance (IsString a) => IsString (BooleanM a) where - fromString = return . fromString +-- | The free Boolean-shaped monad. No refunds. +type BooleanM = Free BooleanF -- | Simple Boolean combinations of 'Term's. -type Simple = BooleanM Term - ------------------------------------------------------------------------- - --- | Conjunction on a list of 'BooleanM' expressions. -fAnd :: [BooleanM a] -> BooleanM a -fAnd = Free . And - --- | Disjunction on a list of 'BooleanM' expressions. -fOr :: [BooleanM a] -> BooleanM a -fOr = Free . Or - --- | Negation of a 'BooleanM' expression. -fNot :: BooleanM a -> BooleanM a -fNot = Free . Not +type Simple = BooleanM (Term Text)