diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Liyang HU + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Liyang HU nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/google-search.cabal b/google-search.cabal new file mode 100644 --- /dev/null +++ b/google-search.cabal @@ -0,0 +1,34 @@ +name: google-search +version: 0.0.1.0 +synopsis: EDSL for Google and GMail search expressions +description: + Construct well-typed search expressions for use in various Google services. +homepage: https://github.com/liyang/google-search +license: BSD3 +license-file: LICENSE +author: Liyang HU +maintainer: google-search@liyang.hu +copyright: © 2013 Liyang HU +category: Language, Text, Web +build-type: Simple +cabal-version: >= 1.8 +stability: experimental + +source-repository head + type: git + location: http://github.com/liyang/google-search + +library + hs-source-dirs: src + exposed-modules: + Language.Google.Search.Simple + Language.Google.Search.Mail + build-depends: + base >= 4.5 && <= 9000, + free >= 2.1, + nats >= 0.1, + old-locale >= 1.0, + text >= 0.11, + time >= 1.4 + ghc-options: -Wall + diff --git a/src/Language/Google/Search/Mail.hs b/src/Language/Google/Search/Mail.hs new file mode 100644 --- /dev/null +++ b/src/Language/Google/Search/Mail.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | + +module Language.Google.Search.Mail where + +import Prelude +import Data.Monoid +import Data.String +import Data.Text (Text) +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as B +import qualified Data.Text.Lazy.Builder.Int as B +import Data.Time.Calendar (Day) +import Data.Time.Format (formatTime) +import Numeric.Natural +import System.Locale (defaultTimeLocale) + +import Language.Google.Search.Simple + +-- | Features for the @has:@ operator. +data Feature + = Attachment + | NoUserLabels + | UserLabels + -- stars + | BlueInfo + | BlueStar + | Circle + | GreenCheck + | GreenStar + | OrangeGuillemet + | OrangeStar + | PurpleQuestion + | PurpleStar + | RedBang + | RedStar + | YellowBang + | YellowStar + deriving (Show) + +-- | Locations for the @in:@ operator. +data Location + = Anywhere + | Inbox + | Trash + | Spam + deriving (Show) + +-- | Statuses for the @is:@ operator. +data Status + = Important + | Starred + | Unread + | Read + | Chat + deriving (Show) + +-- | Categories for the @category:@ operator. +data Category + = Forums + | Personal + | Promotions + | Social + | Updates + deriving (Show) + +-- | GMail search operators. +data MailOp + = Plain Simple + | From Simple + | To Simple + | Subject Simple + | Label Text + | Has Feature + | List Simple + | Filename Simple + | In Location + | Is Status + | Cc Simple + | Bcc Simple + | After Day + | Before Day + | Older Natural Duration + | Newer Natural Duration + | DeliveredTo Simple + | FromCircle Simple + | Category Category + | Larger Natural Size + | Smaller Natural Size + | RFC822MsgId Text + deriving (Show) + +instance IsString MailOp where + fromString = Plain . fromString + +-- | Boolean combinations of GMail operators or 'Plain' 'Simple' terms. +type Mail = BooleanM MailOp + +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 + Attachment -> "attachment" + BlueInfo -> "blue-info" + BlueStar -> "blue-star" + Circle -> "circle" + GreenCheck -> "green-check" + GreenStar -> "green-star" + NoUserLabels -> "nouserlabels" + OrangeGuillemet -> "orange-guillemet" + OrangeStar -> "orange-star" + PurpleQuestion -> "purple-question" + PurpleStar -> "purple-star" + RedBang -> "red-bang" + RedStar -> "red-star" + UserLabels -> "userlabels" + YellowBang -> "yellow-bang" + YellowStar -> "yellow-star" + List s -> "list:" <> searchBuilder s + Filename s -> "filename:" <> searchBuilder s + In l -> "in:" <> case l of + Anywhere -> "anywhere" + Inbox -> "inbox" + Trash -> "trash" + Spam -> "spam" + 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 + 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 + + where + date :: Day -> Builder + date = B.fromString . formatTime defaultTimeLocale "%Y/%m/%d" + + duration :: Natural -> Duration -> Builder + duration n d = B.decimal n <> case d of + Days -> "d" + Months -> "m" + Years -> "y" + + size :: Natural -> Size -> Builder + size n u = B.decimal n <> case u of + Bytes -> mempty + KBytes -> "k" + MBytes -> "m" + diff --git a/src/Language/Google/Search/Simple.hs b/src/Language/Google/Search/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Language/Google/Search/Simple.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +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) +import qualified Data.Text as T +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as B + +-- * Units + +data Duration = Days | Months | Years deriving (Show) +data Size = Bytes | KBytes | MBytes deriving (Show) + +-- | Render a search expression using Google search syntax. +class SearchBuilder e where + searchBuilder :: e -> Builder + +-- | 'SearchBuilder' for 'Free'! +instance (Functor f, SearchBuilder a, SearchBuilder (f Builder)) => + SearchBuilder (Free f a) where + searchBuilder = iter searchBuilder . fmap searchBuilder + +------------------------------------------------------------------------ +-- * 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 + +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 '"') + +------------------------------------------------------------------------ + +-- | The shape of Boolean expressions. +data BooleanF e = Not e | And [e] | Or [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 + +-- | The free Boolean-shaped monad: comes with an 'IsString' instance +-- so we can write @\"simple queries\" :: 'Simple'@. No refunds. +type BooleanM = Free BooleanF + +instance (IsString a) => IsString (BooleanM a) where + fromString = return . fromString + +-- | 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 +