hinquire (empty) → 0.1.0.0
raw patch · 5 files changed
+432/−0 lines, 5 filesdep +QuickCheckdep +basedep +bifunctorssetup-changed
Dependencies added: QuickCheck, base, bifunctors, hinquire, test-framework, test-framework-quickcheck2, test-framework-th
Files
- LICENSE +21/−0
- Setup.hs +2/−0
- hinquire.cabal +46/−0
- src/Network/Hinquire.hs +178/−0
- test/properties.hs +185/−0
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2013 Hardy Jones++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hinquire.cabal view
@@ -0,0 +1,46 @@+-- Initial hinquire.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: hinquire+version: 0.1.0.0+synopsis: Generate armet style query strings.+description: Hinquire is a formalization/testing bed for inquire.js+homepage: https://github.com/joneshf/hinquire+license: MIT+license-file: LICENSE+author: Hardy Jones+maintainer: jones3.hardy@gmail.com+-- copyright:+category: Network+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/joneshf/hinquire.git++library+ exposed-modules: Network.Hinquire+ build-depends: base >=4.6 && <4.7,+ bifunctors >= 4.1.1 && <5.0,+ QuickCheck >= 2.6 && <3.0,+ test-framework >=0.8.0,+ test-framework-quickcheck2 >=0.3.0,+ test-framework-th >= 0.2.0+ hs-source-dirs: src+ default-language: Haskell2010++test-suite properties+ type: exitcode-stdio-1.0+ main-is: properties.hs+ hs-source-dirs: test+ ghc-options: -W -threaded -rtsopts -with-rtsopts=-N+ build-depends: base >=4.6 && <4.7,+ bifunctors >= 4.1.1 && <5.0,+ hinquire >= 0.1.0,+ QuickCheck >= 2.6 && <3.0,+ test-framework >=0.8.0,+ test-framework-quickcheck2 >=0.3.0,+ test-framework-th >= 0.2.0+ default-language: Haskell2010
+ src/Network/Hinquire.hs view
@@ -0,0 +1,178 @@+module Network.Hinquire where++import Prelude hiding (foldr)++import Control.Applicative (Alternative (..), Applicative, pure, (<*>), (<$>))+import Control.Monad+import Data.Biapplicative+import Data.Bifoldable+import Data.Bifunctor+import Data.Bitraversable+import Data.Char+import Data.Foldable+import Data.Monoid+import Data.Traversable++-- | The relation between a key and value "time=now" or "cat!=dog"+data Relation = Equal+ | NEqual+ | GThan+ | GThanE+ | LThan+ | LThanE+ deriving Eq++-- | The boolean operation between a group of Inquires+data GBool = And+ | Or+ deriving Eq++-- | This is an optional negation wrapping an Inquire.+data WBool = NoBool+ | Not+ deriving Eq++-- | The meat of our package. This encapsulates our query logic.+data Inquire k v = Atom+ | Predicate k Relation v+ | Group (Inquire k v) GBool (Inquire k v)+ | Wrap WBool (Inquire k v)+ deriving Eq++-- Algebra stuff++instance Monoid (Inquire k v) where+ mempty = Atom+ mappend = (<&&&>)++instance Functor (Inquire k) where+ fmap _ Atom = Atom+ fmap f (Predicate k r v) = Predicate k r (f v)+ fmap f (Group i1 b i2) = Group (fmap f i1) b (fmap f i2)+ fmap f (Wrap b i) = Wrap b (fmap f i)++instance Monoid k => Applicative (Inquire k) where+ pure = Predicate mempty Equal++ Atom <*> _ = Atom+ _ <*> Atom = Atom+ (Predicate _ _ f) <*> (Predicate k r v) = Predicate k r (f v)+ p@Predicate {} <*> (Group i1 b i2) = Group (p <*> i1) b (p <*> i2)+ p@Predicate {} <*> (Wrap b i) = Wrap b (p <*> i)+ (Group i1 b i2) <*> i3 = Group (i1 <*> i3) b (i2 <*> i3)+ (Wrap b i1) <*> i2 = Wrap b (i1 <*> i2)++instance Monoid k => Alternative (Inquire k) where+ empty = Atom++ Atom <|> i = i+ i <|> _ = i++instance Foldable (Inquire k) where+ foldr _ z Atom = z+ foldr f z (Predicate _ _ v) = f v z+ foldr f z (Group i1 _ i2) = foldr f (foldr f z i2) i1+ foldr f z (Wrap _ i) = foldr f z i++instance Traversable (Inquire k) where+ traverse _ Atom = pure Atom+ traverse f (Predicate k r v) = Predicate <$> pure k <*> pure r <*> f v+ traverse f (Group i1 b i2) =+ Group <$> traverse f i1 <*> pure b <*> traverse f i1+ traverse f (Wrap b i) = Wrap <$> pure b <*> traverse f i++instance Monoid k => Monad (Inquire k) where+ return = Predicate mempty Equal++ Atom >>= _ = Atom+ -- This seems wrong,+ -- we've forgotten everything about our Predicate except the value+ (Predicate _ _ v) >>= f = f v+ (Group i1 b i2) >>= f = Group (i1 >>= f) b (i2 >>= f)+ (Wrap b i) >>= f = Wrap b (i >>= f)++instance Bifunctor Inquire where+ bimap _ _ Atom = Atom+ bimap f g (Predicate k r v) = Predicate (f k) r (g v)+ bimap f g (Group i1 b i2) = Group (bimap f g i1) b (bimap f g i2)+ bimap f g (Wrap b i) = Wrap b (bimap f g i)++instance Bifoldable Inquire where+ bifoldr _ _ z Atom = z+ bifoldr f g z (Predicate k _ v) = f k $ g v z+ bifoldr f g z (Group i1 _ i2) = bifoldr f g (bifoldr f g z i2) i1+ bifoldr f g z (Wrap _ i) = bifoldr f g z i++instance Biapplicative Inquire where+ bipure k = Predicate k Equal++ Atom <<*>> _ = Atom+ _ <<*>> Atom = Atom+ (Predicate f _ g) <<*>> (Predicate k2 r v2) = Predicate (f k2) r (g v2)+ p@Predicate {} <<*>> (Group i1 b i2) = Group (p <<*>> i1) b (p <<*>> i2)+ p@Predicate {} <<*>> (Wrap b i) = Wrap b (p <<*>> i)+ (Group i1 b i2) <<*>> i3 = Group (i1 <<*>> i3) b (i1 <<*>> i3)+ (Wrap b i1) <<*>> i2 = Wrap b (i1 <<*>> i2)++instance Bitraversable Inquire where+ bitraverse _ _ Atom = pure Atom+ bitraverse f g (Predicate k r v) = Predicate <$> f k <*> pure r <*> g v+ bitraverse f g (Group i1 b i2) =+ Group <$> bitraverse f g i1 <*> pure b <*> bitraverse f g i2+ bitraverse f g (Wrap b i) = Wrap <$> pure b <*> bitraverse f g i++class Dyad d where+ bireturn :: a -> b -> d a b+ (>>==) :: d a b -> (a -> b -> d e f) -> d e f++instance Dyad Inquire where+ bireturn k = Predicate k Equal++ Atom >>== _ = Atom+ (Predicate k _ v) >>== f = f k v+ (Group i1 b i2) >>== f = Group (i1 >>== f) b (i2 >>== f)+ (Wrap b i) >>== f = Wrap b (i >>== f)++-- Show stuff.++instance Show Relation where+ show Equal = "="+ show NEqual = "!="+ show GThan = ">"+ show GThanE = ">="+ show LThan = "<"+ show LThanE = "<="++instance Show GBool where+ show And = "&"+ show Or = ";"++instance Show WBool where+ show NoBool = ""+ show Not = "!"++-- This is really ugly to me, perhaps there's a better way.++instance (Show k, Show v) => Show (Inquire k v) where+ show Atom = ""+ show (Predicate k r v) = show k ++ show r ++ show v+ show (Group Atom _ Atom) = ""+ show (Group Atom _ r) = show r+ show (Group l _ Atom) = show l+ show (Group l@Predicate {} b r@Predicate {}) = show l ++ show b ++ show r+ show (Group l@Predicate {} b r) = show l ++ show b ++ "(" ++ show r ++ ")"+ show (Group l b r@Predicate {}) = "(" ++ show l ++ ")" ++ show b ++ show r+ show (Group l b r) = "(" ++ show l ++ ")" ++ show b ++ "(" ++ show r ++ ")"+ show (Wrap n i) = show n ++ "(" ++ show i ++ ")"++-- | Conjoin two Inquires.+(<&&&>) :: Inquire k v -> Inquire k v -> Inquire k v+i1 <&&&> i2 = Group i1 And i2++-- | Disjoin two Inquires.+(<|||>) :: Inquire k v -> Inquire k v -> Inquire k v+i1 <|||> i2 = Group i1 Or i2++-- | Slap a question mark in front of our inquire.+generate :: (Show v, Show k) => Inquire k v -> String+generate = ('?':) . show
+ test/properties.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Control.Applicative+import Control.Monad+import Data.Biapplicative+import Data.Bifunctor+import Data.Bitraversable+import Network.Hinquire+import Test.QuickCheck+import Test.QuickCheck.All+import Test.QuickCheck.Function+import Test.Framework.TH+import Test.Framework.Providers.QuickCheck2++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Data.Foldable (Foldable(foldMap))+import Data.Traversable (Traversable(traverse))++newtype Identity a = Identity { runIdentity :: a } deriving Eq++instance Functor Identity where+ fmap f m = Identity (f (runIdentity m))++instance Foldable Identity where+ foldMap f (Identity x) = f x++instance Traversable Identity where+ traverse f (Identity x) = Identity <$> f x++instance Applicative Identity where+ pure a = Identity a+ Identity f <*> Identity x = Identity (f x)++instance Monad Identity where+ return a = Identity a+ m >>= k = k (runIdentity m)++instance MonadFix Identity where+ mfix f = Identity (fix (runIdentity . f))++newtype Compose f g a = Compose { getCompose :: f (g a) } deriving Eq++instance (Functor f, Functor g) => Functor (Compose f g) where+ fmap f (Compose x) = Compose (fmap (fmap f) x)++instance (Foldable f, Foldable g) => Foldable (Compose f g) where+ foldMap f (Compose t) = foldMap (foldMap f) t++instance (Traversable f, Traversable g) => Traversable (Compose f g) where+ traverse f (Compose t) = Compose <$> traverse (traverse f) t++instance (Applicative f, Applicative g) => Applicative (Compose f g) where+ pure x = Compose (pure (pure x))+ Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)++instance (Alternative f, Applicative g) => Alternative (Compose f g) where+ empty = Compose Control.Applicative.empty+ Compose x <|> Compose y = Compose (x <|> y)++prop_functor_id :: Inquire String String -> Bool+prop_functor_id i = fmap id i == i++prop_functor_comp :: Inquire String String+ -> Fun String String+ -> Fun String String+ -> Bool+prop_functor_comp i (Fun _ f) (Fun _ g) =+ fmap (f . g) i == fmap f (fmap g i)++prop_bifunctor_id :: Inquire String String -> Bool+prop_bifunctor_id i = bimap id id i == i++prop_bifunctor_comp :: Inquire String String+ -> Fun String String+ -> Fun String String+ -> Fun String String+ -> Fun String String+ -> Bool+prop_bifunctor_comp i (Fun _ f1) (Fun _ g1) (Fun _ f2) (Fun _ g2) =+ bimap (f1 . g1) (f2 . g2) i == bimap f1 f2 (bimap g1 g2 i)++prop_applicative_id :: Inquire String String -> Bool+prop_applicative_id i = (pure id <*> i) == i++prop_applicative_composition :: Inquire String String+ -> Fun String String+ -> Fun String String+ -> Bool+prop_applicative_composition w (Fun _ u1) (Fun _ v1) =+ (pure (.) <*> u <*> v <*> w) == (u <*> (v <*> w))+ where u = pure u1+ v = pure v1++prop_applicative_homomorphism :: Fun String String+ -> String+ -> Bool+prop_applicative_homomorphism (Fun _ f) v =+ (pure f <*> pure v :: Inquire String String) == pure (f v)++prop_applicative_interchange :: Fun String String+ -> String+ -> Bool+prop_applicative_interchange (Fun _ f) v =+ (u <*> pure v :: Inquire String String) == (pure ($ v) <*> u)+ where u = pure f++prop_biapplicative_id :: Inquire String String -> Bool+prop_biapplicative_id i = (bipure id id <<*>> i) == i++prop_biapplicative_composition :: Inquire String String+ -> Fun String String+ -> Fun String String+ -> Fun String String+ -> Fun String String+ -> Bool+prop_biapplicative_composition w (Fun _ u1) (Fun _ u2) (Fun _ v1) (Fun _ v2) =+ (bipure (.) (.) <<*>> u <<*>> v <<*>> w) == (u <<*>> (v <<*>> w))+ where u = bipure u1 u2+ v = bipure v1 v2++prop_biapplicative_homomorphism :: Fun String String+ -> Fun String String+ -> String+ -> String+ -> Bool+prop_biapplicative_homomorphism (Fun _ f) (Fun _ g) k v =+ (bipure f g <<*>> bipure k v :: Inquire String String) == bipure (f k) (g v)++prop_biapplicative_interchange :: Fun String String+ -> Fun String String+ -> String+ -> String+ -> Bool+prop_biapplicative_interchange (Fun _ f) (Fun _ g) k v =+ (u <<*>> bipure k v :: Inquire String String) == (bipure ($ k) ($ v) <<*>> u)+ where u = bipure f g++prop_bitraversable_id :: Inquire String String -> Bool+prop_bitraversable_id i =+ bitraverse Identity Identity i == Identity i++--prop_bitraversable_comp :: Inquire String String+-- -> Fun String [String]+-- -> Fun String [String]+-- -> Fun String [String]+-- -> Fun String [String]+-- -> Bool+--prop_bitraversable_comp i (Fun _ f1) (Fun _ f2) (Fun _ g1) (Fun _ g2) =+-- bitraverse (Compose . fmap g1 . f1) (Compose . fmap g2 . f2) i ==+-- (Compose . fmap (bitraverse g1 g2) . (bitraverse f1 f2)) i++instance (Arbitrary k, Arbitrary v) => Arbitrary (Inquire k v) where+ arbitrary = sized inquire+ where+ inquire 0 = return Atom+ inquire 1 = liftM3 Predicate arbitrary rel arbitrary+ inquire n = oneof [ return Atom+ , liftM3 Predicate arbitrary rel arbitrary+ , liftM3 Group inquire' gBool inquire'+ , liftM2 Wrap wBool inquire'+ ]+ where+ inquire' = inquire (n `div` 2)+ rel = elements [Equal, NEqual, GThan, GThanE, LThan, LThanE]+ gBool = elements [And, Or]+ wBool = elements [NoBool, Not]++ shrink Atom = []+ shrink (Predicate k r v) = do+ k' <- shrink k+ v' <- shrink v+ return $ Predicate k' r v'+ shrink (Group i1 b i2) = do+ i1' <- shrink i1+ i2' <- shrink i2+ return $ Group i1' b i2'+ shrink (Wrap b i) = do+ i' <- shrink i+ return $ Wrap b i'++main = $defaultMainGenerator