{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.DSH.Combinators where import Database.DSH.Data import Database.DSH.TH import Data.Convertible import Prelude (Eq, Ord, Num, Bool(..), Integer, Double, Maybe, Either, undefined, error, ($), (.)) -- * Unit unit :: Q () unit = Q (UnitE $ reify (undefined :: ())) -- * Boolean logic false :: Q Bool false = Q (BoolE False BoolT) true :: Q Bool true = Q (BoolE True BoolT) not :: Q Bool -> Q Bool not (Q b) = Q (AppE1 Not b $ reify (undefined :: Bool)) (&&) :: Q Bool -> Q Bool -> Q Bool (&&) (Q a) (Q b) = Q (AppE2 Conj a b $ reify (undefined :: Bool)) (||) :: Q Bool -> Q Bool -> Q Bool (||) (Q a) (Q b) = Q (AppE2 Disj a b $ reify (undefined :: Bool)) -- * Equality and Ordering eq :: (Eq a,QA a) => Q a -> Q a -> Q Bool eq (Q a) (Q b) = Q (AppE2 Equ a b $ reify (undefined :: Bool)) (==) :: (Eq a,QA a) => Q a -> Q a -> Q Bool (==) = eq neq :: (Eq a,QA a) => Q a -> Q a -> Q Bool neq a b = not (eq a b) (/=) :: (Eq a,QA a) => Q a -> Q a -> Q Bool (/=) = neq lt :: (Ord a,QA a) => Q a -> Q a -> Q Bool lt (Q a) (Q b) = Q (AppE2 Lt a b $ reify (undefined :: Bool)) (<) :: (Ord a,QA a) => Q a -> Q a -> Q Bool (<) = lt lte :: (Ord a,QA a) => Q a -> Q a -> Q Bool lte (Q a) (Q b) = Q (AppE2 Lte a b $ reify (undefined :: Bool)) (<=) :: (Ord a,QA a) => Q a -> Q a -> Q Bool (<=) = lte gte :: (Ord a,QA a) => Q a -> Q a -> Q Bool gte (Q a) (Q b) = Q (AppE2 Gte a b $ reify (undefined :: Bool)) (>=) :: (Ord a,QA a) => Q a -> Q a -> Q Bool (>=) = gte gt :: (Ord a,QA a) => Q a -> Q a -> Q Bool gt (Q a) (Q b) = Q (AppE2 Gt a b $ reify (undefined :: Bool)) (>) :: (Ord a,QA a) => Q a -> Q a -> Q Bool (>) = gt min :: forall a. (Ord a, QA a) => Q a -> Q a -> Q a min (Q a) (Q b) = Q (AppE2 Min a b $ reify (undefined :: a)) max :: forall a. (Ord a, QA a) => Q a -> Q a -> Q a max (Q a) (Q b) = Q (AppE2 Max a b $ reify (undefined :: a)) -- * Conditionals -- | Boolean fold -- | It's first argument is used in the case of False -- | It's second argument is used in the case of True -- | The third argument is the boolean bool :: (QA a) => Q a -> Q a -> Q Bool -> Q a bool f t b = cond b t f cond :: forall a. (QA a) => Q Bool -> Q a -> Q a -> Q a cond (Q c) (Q a) (Q b) = Q (AppE3 Cond c a b $ reify (undefined :: a)) (?) :: (QA a) => Q Bool -> (Q a,Q a) -> Q a (?) c (a,b) = cond c a b -- * Maybe listToMaybe :: QA a => Q [a] -> Q (Maybe a) listToMaybe (Q as) = (Q as) maybeToList :: QA a => Q (Maybe a) -> Q [a] maybeToList (Q ma) = (Q ma) nothing :: QA a => Q (Maybe a) nothing = listToMaybe nil just :: QA a => Q a -> Q (Maybe a) just a = listToMaybe (singleton a) isNothing :: QA a => Q (Maybe a) -> Q Bool isNothing ma = null (maybeToList ma) isJust :: QA a => Q (Maybe a) -> Q Bool isJust ma = not (isNothing ma) fromJust :: QA a => Q (Maybe a) -> Q a fromJust ma = head (maybeToList ma) maybe :: (QA a, QA b) => Q b -> (Q a -> Q b) -> Q (Maybe a) -> Q b maybe b f ma = (isNothing ma) ? (b, f (fromJust (ma))) fromMaybe :: QA a => Q a -> Q (Maybe a) -> Q a fromMaybe a ma = (isNothing ma) ? (a, fromJust (ma)) catMaybes :: QA a => Q [Maybe a] -> Q [a] catMaybes mas = concatMap maybeToList mas mapMaybe :: (QA a, QA b) => (Q a -> Q (Maybe b)) -> Q [a] -> Q [b] mapMaybe f as = concatMap (maybeToList . f) as -- * Either left :: (QA a,QA b) => Q a -> Q (Either a b) left a = tupleToEither (tuple ((singleton a),nil)) right :: (QA a,QA b) => Q b -> Q (Either a b) right a = tupleToEither (tuple (nil,(singleton a))) isLeft :: (QA a,QA b) => Q (Either a b) -> Q Bool isLeft = null . snd . eitherToTuple isRight :: (QA a,QA b) => Q (Either a b) -> Q Bool isRight = null . fst . eitherToTuple either :: (QA a,QA b,QA c) => (Q a -> Q c) -> (Q b -> Q c) -> Q (Either a b) -> Q c either lf rf e = (isLeft e) ? ((lf . head . fst . eitherToTuple) e,(rf . head . snd . eitherToTuple) e) lefts :: (QA a,QA b) => Q [Either a b] -> Q [a] lefts = concatMap (fst . eitherToTuple) rights :: (QA a,QA b) => Q [Either a b] -> Q [b] rights = concatMap (snd . eitherToTuple) partitionEithers :: (QA a,QA b) => Q [Either a b] -> Q ([a], [b]) partitionEithers es = tuple (lefts es,rights es) -- * List Construction nil :: forall a. (QA a) => Q [a] nil = Q (ListE [] $ reify (undefined :: [a])) empty :: (QA a) => Q [a] empty = nil cons :: forall a. (QA a) => Q a -> Q [a] -> Q [a] cons (Q a) (Q as) = Q (AppE2 Cons a as $ reify (undefined :: [a])) (<|) :: (QA a) => Q a -> Q [a] -> Q [a] (<|) = cons snoc :: forall a. (QA a) => Q [a] -> Q a -> Q [a] snoc (Q as) (Q a) = Q (AppE2 Snoc as a $ reify (undefined :: [a])) (|>) :: (QA a) => Q [a] -> Q a -> Q [a] (|>) = snoc singleton :: (QA a) => Q a -> Q [a] singleton a = cons a nil -- * List Operations head :: forall a. (QA a) => Q [a] -> Q a head (Q as) = Q (AppE1 Head as $ reify (undefined :: a)) tail :: forall a. (QA a) => Q [a] -> Q [a] tail (Q as) = Q (AppE1 Tail as $ reify (undefined :: [a])) take :: forall a. (QA a) => Q Integer -> Q [a] -> Q [a] take (Q i) (Q as) = Q (AppE2 Take i as $ reify (undefined :: [a])) drop :: forall a. (QA a) => Q Integer -> Q [a] -> Q [a] drop (Q i) (Q as) = Q (AppE2 Drop i as $ reify (undefined :: [a])) map :: forall a b. (QA a, QA b) => (Q a -> Q b) -> Q [a] -> Q [b] map f (Q as) = Q (AppE2 Map (toLam1 f) as $ reify (undefined :: [b])) append :: forall a. (QA a) => Q [a] -> Q [a] -> Q [a] append (Q as) (Q bs) = Q (AppE2 Append as bs $ reify (undefined :: [a])) (><) :: (QA a) => Q [a] -> Q [a] -> Q [a] (><) = append filter :: forall a. (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] filter f (Q as) = Q (AppE2 Filter (toLam1 f) as $ reify (undefined :: [a])) groupWith :: forall a b. (Ord b, QA a, QA b) => (Q a -> Q b) -> Q [a] -> Q [[a]] groupWith f (Q as) = Q (AppE2 GroupWith (toLam1 f) as $ reify (undefined :: [[a]])) sortWith :: forall a b. (Ord b, QA a, QA b) => (Q a -> Q b) -> Q [a] -> Q [a] sortWith f (Q as) = Q (AppE2 SortWith (toLam1 f) as $ reify (undefined :: [a])) the :: forall a. (Eq a, QA a) => Q [a] -> Q a the (Q as) = Q (AppE1 The as $ reify (undefined :: a)) last :: forall a. (QA a) => Q [a] -> Q a last (Q as) = Q (AppE1 Last as $ reify (undefined :: a)) init :: forall a. (QA a) => Q [a] -> Q [a] init (Q as) = Q (AppE1 Init as $ reify (undefined :: [a])) null :: (QA a) => Q [a] -> Q Bool null (Q as) = Q (AppE1 Null as $ reify (undefined :: Bool)) length :: (QA a) => Q [a] -> Q Integer length (Q as) = Q (AppE1 Length as $ reify (undefined :: Integer)) index :: forall a. (QA a) => Q [a] -> Q Integer -> Q a index (Q as) (Q i) = Q (AppE2 Index as i $ reify (undefined :: a)) (!!) :: (QA a) => Q [a] -> Q Integer -> Q a (!!) = index reverse :: forall a. (QA a) => Q [a] -> Q [a] reverse (Q as) = Q (AppE1 Reverse as $ reify (undefined :: [a])) -- * Special folds and :: Q [Bool] -> Q Bool and (Q as) = Q (AppE1 And as $ reify (undefined :: Bool)) or :: Q [Bool] -> Q Bool or (Q as) = Q (AppE1 Or as $ reify (undefined :: Bool)) any :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q Bool any f (Q as) = Q (AppE2 Any (toLam1 f) as $ reify (undefined :: Bool)) all :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q Bool all f (Q as) = Q (AppE2 All (toLam1 f) as $ reify (undefined :: Bool)) sum :: forall a. (QA a, Num a) => Q [a] -> Q a sum (Q as) = Q (AppE1 Sum as $ reify (undefined :: a)) concat :: forall a. (QA a) => Q [[a]] -> Q [a] concat (Q as) = Q (AppE1 Concat as $ reify (undefined :: [a])) concatMap :: (QA a, QA b) => (Q a -> Q [b]) -> Q [a] -> Q [b] concatMap f as = concat (map f as) maximum :: forall a. (QA a, Ord a) => Q [a] -> Q a maximum (Q as) = Q (AppE1 Maximum as $ reify (undefined :: a)) minimum :: forall a. (QA a, Ord a) => Q [a] -> Q a minimum (Q as) = Q (AppE1 Minimum as $ reify (undefined :: a)) -- * Sublists splitAt :: forall a. (QA a) => Q Integer -> Q [a] -> Q ([a], [a]) splitAt (Q i) (Q as) = Q (AppE2 SplitAt i as $ reify (undefined :: ([a],[a]))) takeWhile :: forall a. (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] takeWhile f (Q as) = Q (AppE2 TakeWhile (toLam1 f) as $ reify (undefined :: [a])) dropWhile :: forall a. (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] dropWhile f (Q as) = Q (AppE2 DropWhile (toLam1 f) as $ reify (undefined :: [a])) span :: forall a. (QA a) => (Q a -> Q Bool) -> Q [a] -> Q ([a],[a]) span f (Q as) = Q (AppE2 Span (toLam1 f) as $ reify (undefined :: ([a],[a]))) break :: forall a. (QA a) => (Q a -> Q Bool) -> Q [a] -> Q ([a],[a]) break f (Q as) = Q (AppE2 Break (toLam1 f) as $ reify (undefined :: ([a],[a]))) -- * Searching Lists elem :: forall a. (Eq a, QA a) => Q a -> Q [a] -> Q Bool elem a as = (null (filter (a ==) as)) ? (false,true) notElem :: forall a. (Eq a, QA a) => Q a -> Q [a] -> Q Bool notElem a as = not (elem a as) lookup :: (QA a,QA b,Eq a) => Q a -> Q [(a, b)] -> Q (Maybe b) lookup a = listToMaybe . map snd . filter ((a ==) . fst) -- * Zipping and Unzipping Lists zip :: forall a b. (QA a, QA b) => Q [a] -> Q [b] -> Q [(a,b)] zip (Q as) (Q bs) = Q (AppE2 Zip as bs $ reify (undefined :: [(a,b)])) zipWith :: forall a b c. (QA a, QA b, QA c) => (Q a -> Q b -> Q c) -> Q [a] -> Q [b] -> Q [c] zipWith f (Q as) (Q bs) = Q (AppE3 ZipWith (toLam2 f) as bs $ reify (undefined :: [c])) unzip :: forall a b. (QA a, QA b) => Q [(a,b)] -> Q ([a], [b]) unzip (Q as) = Q (AppE1 Unzip as $ reify (undefined :: ([a],[b]))) -- * "Set" operations nub :: forall a. (Eq a,QA a) => Q [a] -> Q [a] nub (Q as) = Q (AppE1 Nub as $ reify (undefined :: [a])) -- * Tuple Projection Functions fst :: forall a b. (QA a, QA b) => Q (a,b) -> Q a fst (Q a) = Q (AppE1 Fst a $ reify (undefined :: a)) snd :: forall a b. (QA a, QA b) => Q (a,b) -> Q b snd (Q a) = Q (AppE1 Snd a $ reify (undefined :: b)) -- * Conversions between numeric types integerToDouble :: Q Integer -> Q Double integerToDouble (Q a) = Q (AppE1 IntegerToDouble a DoubleT) -- * Convert Haskell values into DB queries toQ :: forall a. (QA a) => a -> Q a toQ c = Q (convert (toNorm c)) -- * Rebind Monadic Combinators return :: (QA a) => Q a -> Q [a] return = singleton (>>=) :: (QA a, QA b) => Q [a] -> (Q a -> Q [b]) -> Q [b] (>>=) ma f = concatMap f ma (>>) :: (QA a, QA b) => Q [a] -> Q [b] -> Q [b] (>>) ma mb = concatMap (\_ -> mb) ma mzip :: (QA a, QA b) => Q [a] -> Q [b] -> Q [(a,b)] mzip = zip guard :: Q Bool -> Q [()] guard c = cond c (singleton unit) nil infixl 9 !! infixr 5 ><, <|, |> infix 4 ==, /=, <, <=, >=, > infixr 3 && infixr 2 || infix 0 ? -- 'QA', 'TA' and 'View' instances for tuples up to the defined length. $(generateDeriveTupleQARange 3 32) $(generateDeriveTupleTARange 3 16) $(generateDeriveTupleViewRange 3 16) -- * Missing Combinators -- $missing {- $missing This module offers most of the functions on lists given in PreludeList for the 'Q' type. Missing functions are: General folds: > foldl > foldl1 > scanl > scanl1 > foldr > foldr1 > scanr > scanr1 Infinit lists: > iterate > repeat > cycle String functions: > lines > words > unlines > unwords Zipping and unzipping lists: > zip3 > zipWith3 > unzip3 -}