DSH 0.8.0.1 → 0.8.1.0

raw patch · 10 files changed

+158/−99 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• DSH.cabal +1/−1
• examples/Example01.hs +1/−1
• src/Database/DSH.hs +5/−0
• src/Database/DSH/Compiler.hs +6/−13
• src/Database/DSH/Externals.hs +29/−12
• src/Database/DSH/Internals.hs +2/−7
• src/Database/DSH/Interpreter.hs +18/−32
• src/Database/DSH/TH.hs +24/−14
• tests/Main.hs +68/−11
• tests/Makefile +4/−8

@@ -1,5 +1,5 @@ Name:                DSH-Version:             0.8.0.1+Version:             0.8.1.0 Synopsis:            Database Supported Haskell Description:   This is a Haskell library for database-supported program execution. Using

@@ -30,4 +30,4 @@ runQ q = getConn P.>>= \conn -> (fromQ conn q P.>>= P.print) P.>> disconnect conn  main :: IO ()-main = (runQ ints) P.>> (runQ query1) P.>> (runQ query2)+main = runQ ints P.>> runQ query1 P.>> runQ query2

@@ -16,6 +16,7 @@ module Database.DSH   ( module Database.DSH.Externals   , Q, QA, Elim, elim, View, view, fromView+  , module Database.DSH.TH   , module Data.String   , module Data.Text   , module Database.HDBC@@ -25,6 +26,7 @@  import Database.DSH.Externals import Database.DSH.Internals (Q,QA,Elim,elim,View,view,fromView)+import Database.DSH.TH  import Data.String (IsString,fromString) import Data.Text (Text)@@ -74,6 +76,9 @@   , zip   , zipWith   , unzip+  , zip3+  , zipWith3+  , unzip3   , fst   , snd   , maybe

@@ -130,27 +130,20 @@ transformE (ListE es) = let ty = reify (undefined :: a)                             qt = ([] :=> transformTy ty)                          in foldr (F.Cons qt) (Nil qt) <$> mapM transformE es-transformE (AppE GroupWith (PairE (gfn :: Exp (ta -> rt)) (e :: Exp el))) = do-  let ty = reify (undefined :: a)+transformE (AppE GroupWithKey (PairE (gfn :: Exp (ta -> rt)) (e :: Exp el))) = do   let tel = reify (undefined :: el)-  let tr = transformTy ty   fn' <- transformLamArg gfn   let (_ :=> tfn@(FFn _ rt)) = typeOf fn'   let gtr = list $ rec [(RLabel "1", rt), (RLabel "2", transformTy $ ListT tel)]   e' <- transformArg e   let (_ :=> te) = typeOf e'   fv <- transformLamArg (LamE id :: Exp (el -> el))-  snd' <- transformLamArg (LamE (\(x :: Exp (rt,[el])) -> AppE Snd x))-  let (_ :=> sndTy) = typeOf snd'   let (_ :=> tfv) = typeOf fv-  return $ App ([] :=> tr)-              (App ([] :=> gtr .-> tr) (Var ([] :=> sndTy .-> gtr .-> tr) "map") snd') -              (ParExpr ([] :=> gtr) $ App ([] :=> gtr)-                  (App ([] :=> te .-> gtr)-                      (App ([] :=> tfn .-> te .-> gtr) (Var ([] :=> tfv .-> tfn .-> te .-> gtr) "groupWith") fv)-                      fn'-                  )-                  e')+  return $ App ([] :=> gtr)+               (App ([] :=> te .-> gtr)+                    (App ([] :=> tfn .-> te .-> gtr) (Var ([] :=> tfv .-> tfn .-> te .-> gtr) "groupWith") fv)+                    fn')+               e' transformE (AppE D.Cons (PairE e1 e2)) = do                                             e1' <- transformE e1                                             e2' <- transformE e2

@@ -236,6 +236,12 @@   view (Q e) = (Q (AppE Fst e),Q (AppE Snd e))   fromView (Q a,Q b) = Q (PairE a b) +instance (QA a,QA b,QA c) => View (Q (a,b,c)) (Q a,Q b,Q c) where+  type ToView (Q (a,b,c)) = (Q a,Q b,Q c)+  type FromView (Q a,Q b,Q c) = (Q (a,b,c))+  view (Q e) = (Q (AppE Fst e),Q (AppE Fst (AppE Snd e)),Q (AppE Snd (AppE Snd e)))+  fromView (Q a,Q b,Q c) = Q (PairE a (PairE b c))+ -- IsString instances  instance IsString (Q Text) where@@ -334,6 +340,9 @@ cond :: (QA a) => Q Bool -> Q a -> Q a -> Q a cond (Q c) (Q a) (Q b) = Q (AppE Cond (PairE c (PairE a b))) +ifThenElse :: (QA a) => Q Bool -> Q a -> Q a -> Q a+ifThenElse = cond+ (?) :: (QA a) => Q Bool -> (Q a,Q a) -> Q a (?) c (a,b) = cond c a b @@ -393,7 +402,9 @@ isRight = null . fst . eitherToPair  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 . eitherToPair) e,(rf . head . snd . eitherToPair) e)+either lf rf e =+  let p = eitherToPair e+  in  head (map lf (fst p) ++ map rf (snd p))  lefts :: (QA a,QA b) => Q [Either a b] -> Q [a] lefts = concatMap (fst . eitherToPair)@@ -453,15 +464,15 @@ filter :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] filter f (Q as) = Q (AppE Filter (PairE (LamE (toLam f)) as)) +groupWithKey :: (QA a,QA b,Ord b) => (Q a -> Q b) -> Q [a] -> Q [(b,[a])]+groupWithKey f (Q as) = Q (AppE GroupWithKey (PairE (LamE (toLam f)) as))+ groupWith :: (QA a,QA b,Ord b) => (Q a -> Q b) -> Q [a] -> Q [[a]]-groupWith f (Q as) = Q (AppE GroupWith (PairE (LamE (toLam f)) as))+groupWith f as = map snd (groupWithKey f as)  sortWith :: (QA a,QA b,Ord b) => (Q a -> Q b) -> Q [a] -> Q [a] sortWith f (Q as) = Q (AppE SortWith (PairE (LamE (toLam f)) as)) -the :: (QA a,Eq a) => Q [a] -> Q a-the (Q as) = Q (AppE The as)- last :: (QA a) => Q [a] -> Q a last (Q as) = Q (AppE Last as) @@ -549,8 +560,20 @@ zipWith f as bs = map (\e -> f (fst e) (snd e)) (zip as bs)  unzip :: (QA a,QA b) => Q [(a,b)] -> Q ([a],[b])-unzip (Q as) = Q (AppE Unzip as)+unzip as = pair (map fst as) (map snd as) +zip3 :: (QA a,QA b,QA c) => Q [a] -> Q [b] -> Q [c] -> Q [(a,b,c)]+zip3 as bs cs = map (\abc -> fromView (fst abc,fst (snd abc),snd (snd abc))) (zip as (zip bs cs))++zipWith3 :: (QA a,QA b,QA c,QA d) => (Q a -> Q b -> Q c -> Q d) -> Q [a] -> Q [b] -> Q [c] -> Q [d]+zipWith3 f as bs cs = map (\e -> (case view e of (a,b,c) -> f a b c))+                          (zip3 as bs cs)++unzip3 :: (QA a,QA b,QA c) => Q [(a,b,c)] -> Q ([a],[b],[c])+unzip3 abcs = fromView ( map (\e -> (case view e of (a,_,_) -> a)) abcs+                       , map (\e -> (case view e of (_,b,_) -> b)) abcs+                       , map (\e -> (case view e of (_,_,c) -> c)) abcs)+ -- * Set-oriented operations  nub :: (QA a,Eq a) => Q [a] -> Q [a]@@ -637,11 +660,5 @@ > words > unlines > unwords--Zipping and unzipping lists:--> zip3-> zipWith3-> unzip3  -}

@@ -37,7 +37,6 @@     Concat          :: (Reify a) => Fun [[a]] [a]     Head            :: Fun [a] a     Tail            :: Fun [a] [a]-    The             :: Fun [a] a     Init            :: Fun [a] [a]     Last            :: Fun [a] a     Null            :: Fun [a] Bool@@ -48,7 +47,6 @@     Sum             :: Fun [a] a     Maximum         :: Fun [a] a     Minimum         :: Fun [a] a-    Unzip           :: (Reify a,Reify b) => Fun [(a,b)] ([a],[b])     Nub             :: Fun [a] [a]     Add             :: Fun (a,a) a     Mul             :: Fun (a,a) a@@ -71,7 +69,7 @@     Zip             :: Fun ([a],[b]) [(a,b)]     Map             :: Fun (a -> b,[a]) [b]     Filter          :: Fun (a -> Bool,[a]) [a]-    GroupWith       :: (Reify b) => Fun (a -> b,[a]) [[a]]+    GroupWithKey    :: Fun (a -> b,[a]) [(b,[a])]     SortWith        :: Fun (a -> b,[a]) [a]     TakeWhile       :: Fun (a -> Bool,[a]) [a]     DropWhile       :: Fun (a -> Bool,[a]) [a]@@ -124,7 +122,6 @@     show Concat = "concat"     show Head = "head"     show Tail = "tail"-    show The = "the"     show Init = "init"     show Last = "last"     show Null = "null"@@ -135,7 +132,6 @@     show Sum = "sum"     show Maximum = "maximum"     show Minimum = "minimum"-    show Unzip = "unzip"     show Nub = "nub"     show IntegerToDouble = "integerToDouble"     show Add = "+"@@ -159,7 +155,7 @@     show Zip = "zip"     show Map = "map"     show Filter = "filter"-    show GroupWith = "groupWith"+    show GroupWithKey = "groupWithKey"     show SortWith = "sortWith"     show TakeWhile = "takeWhile"     show DropWhile = "dropWhile"@@ -193,7 +189,6 @@  instance (Reify a, Reify b) => Reify (a -> b) where   reify _ = ArrowT (reify (undefined :: a)) (reify (undefined :: b))-  -- Utility functions 

@@ -60,14 +60,14 @@       (ListE as1) <- evaluate c as       (ListE as2) <- evaluate c (ListE (map f as1))       return $ ListE (map fst (filter (\(_,BoolE b) -> b) (zip as1 as2))) -    AppE GroupWith (PairE (LamE f) as) -> do+    AppE GroupWithKey (PairE (LamE f) as) -> do       (ListE as1) <- evaluate c as-      (ListE as2) <- evaluate c (ListE (map f as1))+      (ListE ks1) <- evaluate c (ListE (map f as1))       return $ ListE-             $ map (ListE . map fst)-             $ groupBy (\(_,a1) (_,a2) -> equExp a1 a2)-             $ sortBy (\(_,a1) (_,a2) -> compareExp a1 a2)-             $ zip as1 as2+             $ map (\kas1 -> PairE (fst (head kas1)) (ListE (map snd kas1)))+             $ groupBy (\(k1,_) (k2,_) -> equExp k1 k2)+             $ sortBy (\(k1,_) (k2,_) -> compareExp k1 k2)+             $ zip ks1 as1     AppE SortWith (PairE (LamE f) as) -> do       (ListE as1) <- evaluate c as       (ListE as2) <- evaluate c $ ListE (map f as1) @@ -77,33 +77,22 @@              $ zip as1 as2     (AppE Max (PairE e1 e2)) ->       case reify (undefined :: a) of-          IntegerT -> do-                        (IntegerE v1) <- evaluate c e1-                        (IntegerE v2) <- evaluate c e2-                        return $ IntegerE (max v1 v2)-          DoubleT -> do -                        (DoubleE v1) <- evaluate c e1-                        (DoubleE v2) <- evaluate c e2-                        return $ DoubleE (max v1 v2)+          IntegerT -> do (IntegerE v1) <- evaluate c e1+                         (IntegerE v2) <- evaluate c e2+                         return $ IntegerE (max v1 v2)+          DoubleT  -> do (DoubleE v1) <- evaluate c e1+                         (DoubleE v2) <- evaluate c e2+                         return $ DoubleE (max v1 v2)           _ -> $impossible     (AppE Min (PairE e1 e2)) ->       case reify (undefined :: a) of-          IntegerT -> do-                        (IntegerE v1) <- evaluate c e1-                        (IntegerE v2) <- evaluate c e2-                        return $ IntegerE (min v1 v2)-          DoubleT -> do-                        (DoubleE v1) <- evaluate c e1-                        (DoubleE v2) <- evaluate c e2-                        return $ DoubleE (min v1 v2)+          IntegerT -> do (IntegerE v1) <- evaluate c e1+                         (IntegerE v2) <- evaluate c e2+                         return $ IntegerE (min v1 v2)+          DoubleT  -> do (DoubleE v1) <- evaluate c e1+                         (DoubleE v2) <- evaluate c e2+                         return $ DoubleE (min v1 v2)           _ -> $impossible-    AppE The as -> do-      (ListE as1) <- evaluate c as-      case as1 of-        [] -> error "Database.DSH.Interpreter.the: empty list"-        (x : xs) -> return $ if all (equExp x) xs-                                then x-                                else error "Database.DSH.Interpreter.the: non-identical elements"     AppE Last as -> do       (ListE as1) <- evaluate c as       return $ last as1@@ -162,9 +151,6 @@       (ListE as1) <- evaluate c as       (ListE bs1) <- evaluate c bs       return $ ListE (zipWith PairE as1 bs1)-    AppE Unzip as -> do-      (ListE as1) <- evaluate c as-      return $ PairE (ListE (map (\(PairE a _) -> a) as1)) (ListE (map (\(PairE _ b) -> b) as1))     AppE Nub as -> do       (ListE as1) <- evaluate c as       return $ ListE (nubBy equExp as1)

@@ -1,10 +1,21 @@-module Database.DSH.TH (deriveQA, deriveTupleRangeQA, deriveElim) where+module Database.DSH.TH (deriveDSH, deriveQA, deriveTupleRangeQA, deriveElim) where  import qualified Database.DSH.Internals  as DSH import qualified Database.DSH.Impossible as DSH  import Language.Haskell.TH+import Control.Monad +-----------------------------------------+-- Deriving all DSH-relevant instances --+-----------------------------------------++deriveDSH :: Name -> Q [Dec]+deriveDSH n = do+  qa <- deriveQA n+  el <- deriveElim n+  return (qa ++ el)+ ----------------- -- Deriving QA -- -----------------@@ -30,7 +41,7 @@ deriveTupleRangeQA :: Int -> Int -> Q [Dec] deriveTupleRangeQA x y = fmap concat (mapM (deriveQA . tupleTypeName) [x .. y]) --- Derive the Rep type function+-- Deriving the Rep type function  deriveRep :: Type -> [Con] -> Dec deriveRep typ cons = TySynInstD ''DSH.Rep [typ] (deriveRepCons cons)@@ -47,7 +58,7 @@   ts -> foldr1 (AppT . AppT (ConT ''(,)))                (map (AppT (ConT ''DSH.Rep)) ts) --- Derive the toExp function of the QA class+-- Deriving the toExp function of the QA class  deriveToExp :: [Con] -> Q Dec deriveToExp [] = fail errMsgExoticType@@ -80,7 +91,7 @@ deriveToExpMainExp [name] = AppE (VarE 'DSH.toExp) (VarE name) deriveToExpMainExp names  = foldr1 (AppE . AppE (ConE 'DSH.PairE))                                    (map (AppE (VarE 'DSH.toExp) . VarE) names)--- Derive to frExp function of the QA class+-- Deriving to frExp function of the QA class  deriveFrExp :: [Con] -> Q Dec deriveFrExp cons = do@@ -131,15 +142,14 @@   resultTyName <- newName "r"   let resTy = VarT resultTyName   let ty = foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs)-  let context = (ClassP ''DSH.QA [ty])    :-                (ClassP ''DSH.QA [resTy]) :+  let context = ClassP ''DSH.QA [resTy] :                 map (\tv -> ClassP ''DSH.QA [VarT (tyVarBndrToName tv)]) tyVarBndrs   let instanceHead = AppT (AppT (ConT ''DSH.Elim) ty) resTy   let eliminatorDec = deriveEliminator ty resTy cons   elimDec <- deriveElimFun cons   return [InstanceD context instanceHead [eliminatorDec,elimDec]] --- Derive the Eliminator type function+-- Deriving the Eliminator type function  deriveEliminator :: Type -> Type -> [Con] -> Dec deriveEliminator typ resTy cons = TySynInstD ''DSH.Eliminator [typ,resTy] (deriveEliminatorCons resTy cons)@@ -147,17 +157,17 @@ deriveEliminatorCons :: Type -> [Con] -> Type deriveEliminatorCons _ []  = error errMsgExoticType deriveEliminatorCons resTy cs  =-  foldr (AppT . AppT ArrowT)+  foldr (AppT . AppT ArrowT . deriveEliminatorCon resTy)         (AppT (ConT ''DSH.Q) resTy)-        (map (deriveEliminatorCon resTy) cs)+        cs  deriveEliminatorCon :: Type -> Con -> Type deriveEliminatorCon resTy con =-  foldr (AppT . AppT ArrowT)+  foldr (AppT . AppT ArrowT . AppT (ConT ''DSH.Q))         (AppT (ConT ''DSH.Q) resTy)-        (map (AppT (ConT ''DSH.Q)) (conToTypes con))+        (conToTypes con) --- Derive the elim function of the Elim type class+-- Deriving the elim function of the Elim type class  deriveElimFun :: [Con] -> Q Dec deriveElimFun cons = do@@ -169,9 +179,9 @@   en  <- newName "e"   fns <- mapM (\ _ -> newName "f") cons   let fes = map VarE fns-  let pats1 = (ConP 'DSH.Q [VarP en]) : map VarP fns+  let pats1 = ConP 'DSH.Q [VarP en] : map VarP fns -  fes2 <- sequence (zipWith deriveElimToLamExp fes (map (length . conToTypes) cons))+  fes2 <- zipWithM deriveElimToLamExp fes (map (length . conToTypes) cons)    let e       = VarE en   let liste   = AppE (ConE 'DSH.ListE) (ListE (deriveElimFunClauseExp e fes2))

@@ -1,3 +1,6 @@+{-# LANGUAGE TemplateHaskell, GADTs, TypeFamilies, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wall -O3 -fno-warn-orphans #-}+ module Main where  import qualified Database.DSH as Q@@ -12,6 +15,8 @@ import Test.QuickCheck import Test.QuickCheck.Monadic +import Data.DeriveTH+ import Data.List import Data.Maybe import Data.Either@@ -25,6 +30,26 @@ instance Arbitrary Text where   arbitrary = fmap Text.pack arbitrary +data D1 = C11 deriving (Eq,Ord,Show)+derive makeArbitrary ''D1+Q.deriveDSH ''D1++data D2 = C21 | C22 deriving (Eq,Ord,Show)+derive makeArbitrary ''D2+Q.deriveDSH ''D2++data D3 a = C31 a | C32 deriving (Eq,Ord,Show)+derive makeArbitrary ''D3+Q.deriveDSH ''D3++data D4 a = C41 a | C42 | C43 a a | C44 a a a deriving (Eq,Ord,Show)+derive makeArbitrary ''D4+Q.deriveDSH ''D4++data D5 a b c d e = C51 { c511 :: a, c512 :: (a,b,c,d) } | C52 | C53 a b | C54 (a,b,c) | C55 a b c d e deriving (Eq,Ord,Show)+derive makeArbitrary ''D5+Q.deriveDSH ''D5+ getConn :: IO Connection getConn = connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'" @@ -60,6 +85,16 @@     qc prop_maybe_integer     putStrPad "Either Integer Integer: "     qc prop_either_integer+    putStrPad "D1: "+    qc prop_d1+    putStrPad "D2: "+    qc prop_d2+    putStrPad "D3: "+    qc prop_d3+    putStrPad "D4: "+    qc prop_d4+    putStrPad "D5: "+    qc prop_d5      putStrLn ""     putStrLn "Equality, Boolean Logic and Ordering"@@ -192,8 +227,6 @@     qc prop_map     putStrPad "filter"     qc prop_filter-    putStrPad "the"-    qc prop_the     putStrPad "last"     qc prop_last     putStrPad "init"@@ -250,10 +283,16 @@     qc prop_lookup     putStrPad "zip"     qc prop_zip+    putStrPad "zip3"+    qc prop_zip3     putStrPad "zipWith"     qc prop_zipWith+    putStrPad "zipWith3"+    qc prop_zipWith3     putStrPad "unzip"     qc prop_unzip+    putStrPad "unzip3"+    qc prop_unzip3     putStrPad "nub"     qc prop_nub @@ -327,6 +366,21 @@ prop_either_integer :: Either Integer Integer -> Property prop_either_integer = makeProp id id +prop_d1 :: D1 -> Property+prop_d1 = makeProp id id++prop_d2 :: D2 -> Property+prop_d2 = makeProp id id++prop_d3 :: D3 Integer -> Property+prop_d3 = makeProp id id++prop_d4 :: D4 Integer -> Property+prop_d4 = makeProp id id++prop_d5 :: D5 Integer Integer Integer Integer Integer -> Property+prop_d5 = makeProp id id+ -- * Equality, Boolean Logic and Ordering  prop_infix_and :: (Bool,Bool) -> Property@@ -452,14 +506,6 @@ prop_init  :: [Integer] -> Property prop_init  = makePropNotNull Q.init init -prop_the   :: [Integer] -> Property-prop_the l =-        allEqual l-    ==> makeProp Q.the the l-  where-    allEqual []     = False-    allEqual (x:xs) = all (x ==) xs- prop_index :: ([Integer], Integer)  -> Property prop_index (l, i) =         i > 0 && i < fromIntegral (length l)@@ -544,7 +590,7 @@  prop_break :: (Integer, [Integer]) -> Property prop_break = makeProp (uncurryQ $ Q.break . (Q.==))-                     (uncurry   $   break . (==) . fromIntegral)+                      (uncurry   $   break . (==) . fromIntegral)  prop_elem :: (Integer, [Integer]) -> Property prop_elem = makeProp (uncurryQ Q.elem)@@ -566,6 +612,17 @@  prop_unzip :: [(Integer, Integer)] -> Property prop_unzip = makeProp Q.unzip unzip++prop_zip3 :: ([Integer], [Integer],[Integer]) -> Property+prop_zip3 = makeProp (\q -> (case Q.view q of (as,bs,cs) -> Q.zip3 as bs cs))+                     (\(as,bs,cs) -> zip3 as bs cs)++prop_zipWith3 :: ([Integer], [Integer],[Integer]) -> Property+prop_zipWith3 = makeProp (\q -> (case Q.view q of (as,bs,cs) -> Q.zipWith3 (\a b c -> a + b + c) as bs cs))+                         (\(as,bs,cs) -> zipWith3 (\a b c -> a + b + c) as bs cs)++prop_unzip3 :: [(Integer, Integer, Integer)] -> Property+prop_unzip3 = makeProp Q.unzip3 unzip3  prop_nub :: [Integer] -> Property prop_nub = makeProp Q.nub nub

@@ -1,15 +1,11 @@ all: cabal-		ghc -Wall -O3 -fno-warn-orphans --make Main.hs -o Main+		ghc --make Main.hs -o Main 		./Main -hpc: cabal-		mkdir tmp-		ghc -Wall -i../src -i../dist/build/autogen -outputdir tmp -fforce-recomp -O3 -fhpc --make Main.hs -o Main-		./Main-		hpc report Main-		hpc markup Main- cabal: clean+		cabal install quickcheck+		cabal install hdbc-postgresql+		cabal install derive 		cd ..; cabal install; cd tests;  clean: