DSH 0.4.3 → 0.5
raw patch · 11 files changed
+279/−303 lines, 11 files
Files
- DSH.cabal +1/−1
- src/Database/DSH.hs +6/−2
- src/Database/DSH/CSV.hs +56/−35
- src/Database/DSH/Combinators.hs +26/−13
- src/Database/DSH/Compile.hs +6/−5
- src/Database/DSH/Compiler.hs +7/−5
- src/Database/DSH/Data.hs +25/−43
- src/Database/DSH/Interpreter.hs +0/−5
- src/Database/DSH/QQ.hs +3/−3
- src/Database/DSH/TH.hs +0/−1
- tests/Main.hs +149/−190
DSH.cabal view
@@ -1,5 +1,5 @@ Name: DSH-Version: 0.4.3+Version: 0.5 Synopsis: Database Supported Haskell Description: This is a Haskell library for database-supported program execution. Using
src/Database/DSH.hs view
@@ -19,7 +19,6 @@ -- * Data Types , Q- , Time -- * Type Classes , QA@@ -33,15 +32,18 @@ , generateRecords , generateInstances + , module Database.DSH.CSV+ , module Data.Text , module Database.HDBC , module Prelude ) where -import Database.DSH.Data (Q, QA, TA, Time, table, tableDB, tableCSV, tableWithKeys, BasicType, View, view, fromView, tuple, record)+import Database.DSH.Data (Q, QA, TA, table, tableDB, tableCSV, tableWithKeys, BasicType, View, view, fromView, tuple, record) import Database.DSH.QQ (qc) import Database.DSH.TH (generateRecords, generateInstances)+import Database.DSH.CSV (csvExport) import Database.DSH.Combinators @@ -86,6 +88,8 @@ , dropWhile , span , break+ , elem+ , notElem , zip , zipWith , unzip
src/Database/DSH/CSV.hs view
@@ -1,13 +1,41 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, RelaxedPolyRec, OverloadedStrings #-} -module Database.DSH.CSV (csvImport) where+module Database.DSH.CSV (csvImport, csvExport) where import Database.DSH.Data import Database.DSH.Impossible import Text.CSV-import qualified Data.Text as Text+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T +csvExport :: (TA a) => FilePath -> [a] -> IO ()+csvExport file as = T.writeFile file csvContent+ where csvContent :: Text+ csvContent = T.unlines (map (toRow . toNorm) as)++ quote :: Text -> Text+ quote s = T.concat ["\"",s,"\""]+ + escape :: Text -> Text+ escape = (T.replace "\t" "\\t") .+ (T.replace "\r" "\\r") .+ (T.replace "\n" "\\n") .+ (T.replace "\"" "\"\"")++ toRow :: Norm -> Text+ toRow e = case e of+ ListN _ _ -> $impossible+ UnitN _ -> quote "()"+ BoolN b _ -> quote (T.pack (show b))+ CharN c _ -> quote (escape (T.singleton c))+ IntegerN i _ -> quote (T.pack (show i))+ DoubleN d _ -> quote (T.pack (show d))+ TextN t _ -> quote (escape t)+ TupleN e1 e2 _ -> T.concat [toRow e1,",",toRow e2]++ csvImport :: FilePath -> Type -> IO Norm csvImport filepath csvType = do let rType = recordType csvType@@ -16,38 +44,31 @@ Left er -> error (show er) Right r -> filter (\l -> not (all null l) || length l > 1) (tail r) return (ListN (fmap (csvRecordToNorm rType) csv1) (ListT rType))+ where csvError :: String -> a+ csvError s = error ("Error in '" ++ filepath ++ "': " ++ s) - where+ recordType :: Type -> Type+ recordType (ListT rType) = rType+ recordType _ = $impossible - csvError :: String -> a- csvError s = error ("Error in '" ++ filepath ++ "': " ++ s)- - recordType :: Type -> Type- recordType (ListT rType) = rType- recordType _ = $impossible- - csvRecordToNorm :: Type -> [String] -> Norm- csvRecordToNorm t rs = case (t,rs) of- (UnitT , [] ) -> UnitN UnitT- (_ , [] ) -> er- (t1 , [bs] ) -> csvFieldToNorm t1 bs- (TupleT t1 t2, bs : bss) -> TupleN (csvFieldToNorm t1 bs) (csvRecordToNorm t2 bss) (TupleT t1 t2)- (_ , _ ) -> er- where- er = csvError ("When converting record '" ++ show rs ++ "' to a value of type '" ++ show t ++ "'")- + csvRecordToNorm :: Type -> [String] -> Norm+ csvRecordToNorm t rs = case (t,rs) of+ (UnitT , [] ) -> UnitN UnitT+ (_ , [] ) -> er+ (t1 , [bs] ) -> csvFieldToNorm t1 bs+ (TupleT t1 t2, bs : bss) -> TupleN (csvFieldToNorm t1 bs) (csvRecordToNorm t2 bss) (TupleT t1 t2)+ (_ , _ ) -> er+ where er = csvError ("When converting record '" ++ show rs ++ "' to a value of type '" ++ show t ++ "'") - csvFieldToNorm :: Type -> String -> Norm- csvFieldToNorm t s = case t of- UnitT -> UnitN UnitT- BoolT -> BoolN (read s) BoolT- CharT -> CharN (head s) CharT- IntegerT -> IntegerN (read s) IntegerT- DoubleT -> DoubleN (read s) DoubleT- TextT -> TextN (Text.pack s) TextT- TimeT -> er- TupleT _ _ -> er- ListT _ -> er- ArrowT _ _ -> er- where- er = csvError ("When converting CSV field'" ++ s ++ "' to a value of type '" ++ show t ++ "'")+ csvFieldToNorm :: Type -> String -> Norm+ csvFieldToNorm t s = case t of+ UnitT -> UnitN UnitT+ BoolT -> BoolN (read s) BoolT+ CharT -> CharN (head s) CharT+ IntegerT -> IntegerN (read s) IntegerT+ DoubleT -> DoubleN (read s) DoubleT+ TextT -> TextN (T.pack s) TextT+ TupleT _ _ -> er+ ListT _ -> er+ ArrowT _ _ -> er+ where er = csvError ("When converting CSV field'" ++ s ++ "' to a value of type '" ++ show t ++ "'")
src/Database/DSH/Combinators.hs view
@@ -8,7 +8,7 @@ import Data.Convertible -import Prelude (Eq, Ord, Num, Bool, Integer, Double, undefined, error, ($))+import Prelude (Eq, Ord, Num, Bool(..), Integer, Double, undefined, error, ($)) -- * Unit @@ -17,6 +17,12 @@ -- * 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)) @@ -72,16 +78,19 @@ -- * Conditionals--cond :: (QA a) => Q a -> Q a -> Q Bool -> Q a-cond a b c = c ? (a,b)-+-- | 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 = cond+bool f t b = cond b t f -(?) :: forall a. (QA a) => Q Bool -> (Q a,Q a) -> Q a-(?) (Q c) (Q a,Q b) = Q (AppE3 Cond c a b $ reify (undefined :: a))+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+ -- * List Construction nil :: forall a. (QA a) => Q [a]@@ -208,6 +217,15 @@ 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)+ -- * Zipping and Unzipping Lists zip :: forall a b. (QA a, QA b) => Q [a] -> Q [b] -> Q [(a,b)]@@ -277,11 +295,6 @@ > foldr1 > scanr > scanr1--searching lists:--> elem-> notElem Infinit lists:
src/Database/DSH/Compile.hs view
@@ -170,15 +170,16 @@ processResults' q c vals t@(ListT _) = do nestQ <- findQuery (q, c) list <- processResults nestQ t+ i <- getColResPos q c+ let (maxV, vals') = foldr (\v (m,vs) -> let v' = (convert $ v !! i)::Int + in (m `max` v', v':vs)) (1,[]) vals let maxI = if null list then 1 else fst $ L.maximumBy (\x y -> fst x `compare` fst y) list- let lA = (A.accumArray ($impossible) Nothing (1,maxI) []) A.// map (\(x,y) -> (x, Just y)) list- i <- getColResPos q c- return $ map (\val -> case lA A.! ((convert $ val !! i)::Int) of+ let lA = (A.accumArray ($impossible) Nothing (1,maxI `max` maxV) []) A.// map (\(x,y) -> (x, Just y)) list+ return $ map (\val -> case lA A.! val of Just x -> x- Nothing -> ListN [] t) vals-processResults' _ _ _ (TimeT) = error "Results processing for time has not been implemented."+ Nothing -> ListN [] t) vals' processResults' _ _ _ (ArrowT _ _) = $impossible -- The result cannot be a function processResults' q c vals t = do i <- getColResPos q c
src/Database/DSH/Compiler.hs view
@@ -5,7 +5,7 @@ {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, ScopedTypeVariables #-} -module Database.DSH.Compiler (fromQ, debugPlan, debugPlanOpt, debugSQL) where+module Database.DSH.Compiler (fromQ, debugPlan, debugCore, debugPlanOpt, debugSQL) where import Database.DSH.Data as D import Database.DSH.Impossible (impossible)@@ -90,7 +90,12 @@ p <- doCompile q c (C.Algebra r) <- algToAlg ((C.Algebra p)::AlgebraXML a) return r- ++debugCore :: (QA a, IConnection conn) => conn -> Q a -> IO String+debugCore c (Q a) = do+ core <- runN c $ transformE a+ return $ show core+ -- | Convert the query into SQL debugSQL :: (QA a, IConnection conn) => conn -> Q a -> IO String debugSQL q c = do@@ -126,14 +131,12 @@ transformE (IntegerE i _) = return $ Constant ([] :=> int) $ CInt i transformE (DoubleE d _) = return $ Constant ([] :=> float) $ CFloat d transformE (TextE t _) = return $ Constant ([] :=> string) $ CString $ unpack t-transformE (TimeE _ _) = error "transformation of time values has not been implemented yet." transformE (TupleE e1 e2 ty) = do c1 <- transformE e1 c2 <- transformE e2 return $ Rec ([] :=> transformTy ty) [RecElem (typeOf c1) "1" c1, RecElem (typeOf c2) "2" c2] transformE (ListE es ty) = let qt = ([] :=> transformTy ty) in foldr (\h t -> F.Cons qt h t) (Nil qt) <$> mapM transformE es-transformE (AppE f a _) = transformE $ f a transformE (AppE1 f1 e1 ty) = do let tr = transformTy ty e1' <- transformArg e1@@ -286,7 +289,6 @@ transformTy TextT = string transformTy IntegerT = int transformTy DoubleT = float-transformTy TimeT = error "transformation of time types has not been implemented yet." transformTy (TupleT t1 t2) = FRec [(RLabel "1", transformTy t1), (RLabel "2", transformTy t2)] transformTy (ListT t1) = FList $ transformTy t1 transformTy (ArrowT t1 t2) = (transformTy t1) .-> (transformTy t2)
src/Database/DSH/Data.hs view
@@ -12,12 +12,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T --- import Data.Time import GHC.Exts -type Time = Integer-type Real = Double- data Exp = UnitE Type | BoolE Bool Type@@ -25,18 +21,19 @@ | IntegerE Integer Type | DoubleE Double Type | TextE Text Type- | TimeE Time Type | TupleE Exp Exp Type | ListE [Exp] Type | LamE (Exp -> Exp) Type- | AppE (Exp -> Exp) Exp Type | AppE1 Fun1 Exp Type | AppE2 Fun2 Exp Exp Type | AppE3 Fun3 Exp Exp Exp Type | TableE Table Type | VarE Int Type- deriving (Data, Typeable)+ deriving (Show, Data, Typeable) +instance Show (Exp -> Exp) where+ show _ = "(f :: Exp -> Exp)"+ data Fun1 = Fst | Snd | Not | IntegerToDouble | Head | Tail | Unzip | Minimum@@ -66,7 +63,6 @@ | IntegerN Integer Type | DoubleN Double Type | TextN Text Type- | TimeN Time Type | TupleN Norm Norm Type | ListN [Norm] Type deriving (Eq, Ord, Show, Data, Typeable)@@ -78,7 +74,6 @@ | IntegerT | DoubleT | TextT- | TimeT | TupleT Type Type | ListT Type | ArrowT Type Type@@ -99,11 +94,9 @@ IntegerE _ t -> t DoubleE _ t -> t TextE _ t -> t- TimeE _ t -> t TupleE _ _ t -> t ListE _ t -> t LamE _ t -> t- AppE _ _ t -> t AppE1 _ _ t -> t AppE2 _ _ _ t -> t AppE3 _ _ _ _ t -> t@@ -125,7 +118,7 @@ typeNorm :: Norm -> Type typeNorm = typeExp . convert -data Q a = Q Exp+data Q a = Q Exp deriving (Show, Data, Typeable) class QA a where reify :: a -> Type@@ -168,13 +161,6 @@ fromNorm (TextN t TextT) = t fromNorm _ = $impossible --- instance QA Time where--- reify _ = TimeT--- toNorm t = TimeN t TimeT--- fromNorm (TimeN t TimeT) = t--- fromNorm _ = $impossible-- instance (QA a,QA b) => QA (a,b) where reify _ = TupleT (reify (undefined :: a)) (reify (undefined :: b)) toNorm (a,b) = TupleN (toNorm a) (toNorm b) (reify (a,b))@@ -195,7 +181,6 @@ instance BasicType Integer where instance BasicType Double where instance BasicType Text where--- instance BasicType Time where -- * Refering to Real Database Tables @@ -225,10 +210,7 @@ instance TA Text where instance (BasicType a, BasicType b, QA a, QA b) => TA (a,b) where --- * Eq, Ord, Show and Num Instances for Databse Queries--instance Show (Q a) where- show _ = "Query"+-- * Eq, Ord and Num Instances for Databse Queries instance Eq (Q Integer) where (==) _ _ = error "Eq instance for (Q Integer) must not be used."@@ -319,10 +301,6 @@ view = id fromView = id --- instance View (Q Time) (Q Time) where--- view = id--- fromView = id- instance (QA a,QA b) => View (Q (a,b)) (Q a, Q b) where view (Q a) = (Q (AppE1 Fst a (reify (undefined :: a))), Q (AppE1 Snd a (reify (undefined :: b)))) fromView ((Q e1),(Q e2)) = Q (TupleE e1 e2 (reify (undefined :: (a, b))))@@ -334,7 +312,6 @@ BoolN b t -> BoolE b t CharN c t -> CharE c t TextN s t -> TextE s t- TimeN u t -> TimeE u t IntegerN i t -> IntegerE i t DoubleN d t -> DoubleE d t TupleN n1 n2 t -> TupleE (convert n1) (convert n2) t@@ -366,7 +343,6 @@ BoolT -> Right SqlBitT CharT -> Right SqlCharT TextT -> Right SqlVarCharT- TimeT -> Right SqlTimestampT UnitT -> convError "No `UnitT' representation" n TupleT {} -> convError "No `TupleT' representation" n ListT {} -> convError "No `ListT' representation" n@@ -375,15 +351,23 @@ instance Convertible SqlTypeId Type where safeConvert n = case n of- SqlBigIntT -> Right IntegerT- SqlDoubleT -> Right DoubleT- SqlRealT -> Right DoubleT- SqlBitT -> Right BoolT- SqlCharT -> Right CharT- SqlVarCharT -> Right TextT- SqlDateT -> Right TimeT- SqlTimestampT -> Right TimeT- _ -> convError "Unsupported `SqlTypeId'" n+ SqlCharT -> Right TextT+ SqlVarCharT -> Right TextT+ SqlLongVarCharT -> Right TextT+ SqlWCharT -> Right TextT+ SqlWVarCharT -> Right TextT+ SqlWLongVarCharT -> Right TextT+ SqlDecimalT -> Right DoubleT+ SqlNumericT -> Right DoubleT+ SqlSmallIntT -> Right IntegerT+ SqlIntegerT -> Right IntegerT+ SqlRealT -> Right DoubleT+ SqlFloatT -> Right DoubleT+ SqlDoubleT -> Right DoubleT+ SqlBitT -> Right BoolT+ SqlBigIntT -> Right IntegerT+ SqlTinyIntT -> Right IntegerT+ _ -> convError "Unsupported `SqlTypeId'" n instance Convertible SqlValue Norm where@@ -396,8 +380,6 @@ SqlChar c -> Right $ CharN c CharT SqlString t -> Right $ TextN (T.pack t) TextT SqlByteString s -> Right $ TextN (T.decodeUtf8 s) TextT- -- SqlLocalTime t -> Right $ TimeN (localTimeToUTC utc t) TimeT- -- SqlLocalDate d -> Right $ TimeN (UTCTime d 0) TimeT _ -> convError "Unsupported `SqlValue'" sql instance Convertible (SqlValue, Type) Norm where@@ -410,6 +392,7 @@ (SqlInt64 i, IntegerT) -> Right $ flip IntegerN IntegerT $ convert i (SqlWord32 i, IntegerT) -> Right $ flip IntegerN IntegerT $ convert i (SqlWord64 i, IntegerT) -> Right $ flip IntegerN IntegerT $ convert i+ (SqlRational r, IntegerT) -> Right $ flip IntegerN IntegerT $ convert r (SqlDouble d, DoubleT) -> Right $ DoubleN d DoubleT (SqlRational r, DoubleT) -> Right $ flip DoubleN DoubleT $ convert r@@ -433,7 +416,7 @@ (SqlString (c : _), CharT) -> Right $ CharN c CharT (SqlByteString ((T.unpack . T.decodeUtf8) -> (c : _)), CharT) -> Right $ CharN c CharT - _ -> error (show sql) + _ -> $impossible instance Convertible Norm SqlValue where safeConvert n =@@ -444,7 +427,6 @@ BoolN b _ -> Right $ SqlBool b CharN c _ -> Right $ SqlChar c TextN t _ -> Right $ SqlString $ T.unpack t- TimeN _t _ -> convError "Cannot convert `Norm' to `SqlValue'" n -- Right $ SqlUTCTime t ListN _ _ -> convError "Cannot convert `Norm' to `SqlValue'" n TupleN _ _ _ -> convError "Cannot convert `Norm' to `SqlValue'" n
src/Database/DSH/Interpreter.hs view
@@ -29,13 +29,10 @@ IntegerE i t -> return (IntegerN i t) DoubleE d t -> return (DoubleN d t) TextE s t -> return (TextN s t)- TimeE u t -> return (TimeN u t) VarE _ _ -> $impossible LamE _ _ -> $impossible - AppE f1 e1 _ -> evaluate c (f1 e1)- TupleE e1 e2 t -> do e3 <- evaluate c e1 e4 <- evaluate c e2@@ -401,6 +398,4 @@ (CharT , SqlChar _) -> True (TextT , SqlString _) -> True (TextT , SqlByteString _) -> True- (TimeT , SqlLocalTime _) -> True- (TimeT , SqlLocalDate _) -> True _ -> False
src/Database/DSH/QQ.hs view
@@ -24,10 +24,10 @@ import Data.Version (showVersion) combinatorMod :: ModuleName-combinatorMod = ModuleName "database.DSH.Combinators"+combinatorMod = ModuleName "Database.DSH" dataMod :: ModuleName-dataMod = ModuleName "database.DSH.Data"+dataMod = ModuleName "Database.DSH" {- N monad, version of the state monad that can provide fresh variable names.@@ -142,7 +142,7 @@ normaliseQual :: QualStmt -> N Exp normaliseQual (QualStmt (Generator _ _ e)) = pure $ e-normaliseQual (QualStmt (Qualifier e)) = pure $ boolF (consF unit nilF) nilF e+normaliseQual (QualStmt (Qualifier e)) = pure $ boolF nilF (consF unit nilF) e normaliseQual (QualStmt (LetStmt (BDecls bi@[PatBind _ p _ _ _]))) = pure $ flip consF nilF $ letE bi $ patToExp p normaliseQual _ = $impossible
src/Database/DSH/TH.hs view
@@ -486,7 +486,6 @@ CharT -> ConT ''Char DoubleT -> ConT ''Double TextT -> ConT ''Text- TimeT -> ConT ''Time _ -> $impossible in return (mkName n, NotStrict, t')
tests/Main.hs view
@@ -29,12 +29,12 @@ getConn = connectPostgreSQL "user = 'postgres' password = 'haskell98' host = 'localhost' dbname = 'ferry'" qc:: Testable prop => prop -> IO ()-qc = quickCheckWith stdArgs{maxSuccess = 10, maxSize = 10}+qc = quickCheckWith stdArgs{maxSuccess = 100, maxSize = 10} main :: IO () main = do- putStrLn "Running DSH prelude tests"- putStrLn "-------------------------"+ putStrLn "Basic Types"+ putStrLn "-----------" putStr "unit: " qc prop_unit putStr "Bool: "@@ -49,8 +49,8 @@ qc prop_double putStrLn ""- putStrLn "Equality & Ordering"- putStrLn "-------------------------"+ putStrLn "Equality, Boolean Logic and Ordering"+ putStrLn "------------------------------------" putStr "&&: " qc prop_infix_and putStr "||: "@@ -58,9 +58,11 @@ putStr "not: " qc prop_not putStr "eq: "- qc prop_eq_int+ qc prop_eq putStr "neq: "- qc prop_neq_int+ qc prop_neq+ putStr "cond: "+ qc prop_cond putStr "lt: " qc prop_lt putStr "lte: "@@ -79,22 +81,16 @@ qc prop_max_double putStrLn ""- putStrLn "Tuple projection functions"- putStrLn "-------------------------"+ putStrLn "Tuples"+ putStrLn "------" putStr "fst: " qc prop_fst putStr "snd: " qc prop_snd putStrLn ""- putStrLn "Conditionals:"- putStrLn "-------------------------"- putStr "cond: "- qc prop_cond-- putStrLn ""- putStrLn "Numerical operations:"- putStrLn "-------------------------"+ putStrLn "Numerics:"+ putStrLn "-----------" putStr "add_integer: " qc prop_add_integer putStr "add_double: "@@ -122,7 +118,13 @@ putStrLn "" putStrLn "Lists"- putStrLn "-------------------------"+ putStrLn "-----"+ putStr "[Integer]: "+ qc prop_list_1+ putStr "[[Integer]]: "+ qc prop_list_2+ putStr "[[[Integer]]]: "+ qc prop_list_3 putStr "head: " qc prop_head putStr "tail: "@@ -159,10 +161,6 @@ qc prop_groupWith_id putStr "sortWith_id: " qc prop_sortWith_id-- putStrLn ""- putStrLn "Special folds"- putStrLn "-------------------------" putStr "and: " qc prop_and putStr "or: "@@ -183,10 +181,6 @@ qc prop_maximum putStr "minimum: " qc prop_minimum-- putStrLn ""- putStrLn "Sublists"- putStrLn "-------------------------" putStr "splitAt: " qc prop_splitAt putStr "takeWhile: "@@ -197,168 +191,155 @@ qc prop_span putStr "break: " qc prop_break-- putStrLn ""- putStrLn "Zipping and unzipping lists"- putStrLn "-------------------------"+ putStr "elem: "+ qc prop_elem+ putStr "notElem: "+ qc prop_notElem putStr "zip: " qc prop_zip putStr "zipWith_plus: " qc prop_zipWith_plus putStr "unzip: " qc prop_unzip-- putStrLn ""- putStrLn "Set operations"- putStrLn "-------------------------" putStr "nub: " qc prop_nub -runTest :: (Eq b, QA a, QA b, Show a, Show b)- => (Q a -> Q b)- -> (a -> b)- -> a- -> Property-runTest q f arg = monadicIO $ do- c <- run $ getConn- db <- run $ fromQ c (q (Q.toQ arg))- run $ HDBC.disconnect c- let hs = f arg+makeProp :: (Eq b, QA a, QA b, Show a, Show b)+ => (Q a -> Q b)+ -> (a -> b)+ -> a+ -> Property+makeProp f1 f2 arg = monadicIO $ do+ c <- run getConn+ db <- run $ fromQ c $ f1 (Q.toQ arg)+ run (HDBC.disconnect c)+ let hs = f2 arg assert (db == hs) -testNotNull :: (Eq b, Q.QA a, Q.QA b, Show a, Show b)- => (Q.Q [a] -> Q.Q b)- -> ([a] -> b)- -> [a]- -> Property-testNotNull q f arg = not (null arg) ==> runTest q f arg+makePropNotNull :: (Eq b, Q.QA a, Q.QA b, Show a, Show b)+ => (Q.Q [a] -> Q.Q b)+ -> ([a] -> b)+ -> [a]+ -> Property+makePropNotNull q f arg = not (null arg) ==> makeProp q f arg -runTestDouble :: (QA a, Show a)- => (Q a -> Q Double)- -> (a -> Double)- -> a- -> Property-runTestDouble q f arg = monadicIO $ do+makePropDouble :: (QA a, Show a)+ => (Q a -> Q Double)+ -> (a -> Double)+ -> a+ -> Property+makePropDouble f1 f2 arg = monadicIO $ do c <- run $ getConn- db <- run $ fromQ c (q (Q.toQ arg))+ db <- run $ fromQ c $ f1 (Q.toQ arg) run $ HDBC.disconnect c- let hs = f arg+ let hs = f2 arg let eps = 1.0E-8 :: Double; - assert (abs(db - hs) < eps)-+ assert (abs (db - hs) < eps) +uncurryQ :: (Q.QA a, Q.QA b) => (Q.Q a -> Q.Q b -> Q.Q c) -> Q.Q (a,b) -> Q.Q c+uncurryQ f = uncurry f . Q.view -uncurry_Q :: (Q.QA a, Q.QA b) => (Q.Q a -> Q.Q b -> Q.Q c) -> Q.Q (a,b) -> Q.Q c-uncurry_Q q = uncurry q . Q.view+-- * Basic Types prop_unit :: () -> Property-prop_unit = runTest id id+prop_unit = makeProp id id prop_bool :: Bool -> Property-prop_bool = runTest id id+prop_bool = makeProp id id prop_integer :: Integer -> Property-prop_integer = runTest id id+prop_integer = makeProp id id prop_double :: Double -> Property-prop_double = runTestDouble id id--isValidXmlChar :: Char -> Bool-isValidXmlChar c =- '\x0009' <= c && c <= '\x000A'- || '\x000D' <= c && c <= '\x000D'- || '\x0020' <= c && c <= '\xD7FF'- || '\xE000' <= c && c <= '\xFFFD'- || '\x10000'<= c && c <= '\x10FFFF'+prop_double = makePropDouble id id prop_char :: Char -> Property-prop_char c = isPrint c ==> runTest id id c+prop_char c = isPrint c ==> makeProp id id c prop_text :: Text -> Property-prop_text t = Text.all isPrint t ==> runTest id id t--+prop_text t = Text.all isPrint t ==> makeProp id id t ------------------------------------------------------------------------------------ Equality & Ordering+-- * Equality, Boolean Logic and Ordering prop_infix_and :: (Bool,Bool) -> Property-prop_infix_and = runTest (uncurry_Q (Q.&&)) (uncurry (&&))+prop_infix_and = makeProp (uncurryQ (Q.&&)) (uncurry (&&)) prop_infix_or :: (Bool,Bool) -> Property-prop_infix_or = runTest (uncurry_Q (Q.||)) (uncurry (||))+prop_infix_or = makeProp (uncurryQ (Q.||)) (uncurry (||)) prop_not :: Bool -> Property-prop_not = runTest Q.not not--prop_eq :: (Eq a, Q.QA a, Show a) => (a,a) -> Property-prop_eq = runTest (\q -> Q.fst q Q.== Q.snd q) (\(a,b) -> a == b)+prop_not = makeProp Q.not not -prop_eq_int :: (Integer,Integer) -> Property-prop_eq_int = prop_eq+prop_eq :: (Integer,Integer) -> Property+prop_eq = makeProp (uncurryQ (Q.==)) (uncurry (==)) -prop_neq :: (Eq a, Q.QA a, Show a) => (a,a) -> Property-prop_neq = runTest (uncurry_Q (Q./=)) (\(a,b) -> a /= b)+prop_neq :: (Integer,Integer) -> Property+prop_neq = makeProp (uncurryQ (Q./=)) (uncurry (/=)) -prop_neq_int :: (Integer,Integer) -> Property-prop_neq_int = prop_eq+prop_cond :: Bool -> Property+prop_cond = makeProp (\b -> Q.cond b (0 :: Q Integer) 1) (\b -> if b then 0 else 1) prop_lt :: (Integer, Integer) -> Property-prop_lt = runTest (uncurry_Q (Q.<)) (uncurry (<))+prop_lt = makeProp (uncurryQ (Q.<)) (uncurry (<)) prop_lte :: (Integer, Integer) -> Property-prop_lte = runTest (uncurry_Q (Q.<=)) (uncurry (<=))+prop_lte = makeProp (uncurryQ (Q.<=)) (uncurry (<=)) prop_gt :: (Integer, Integer) -> Property-prop_gt = runTest (uncurry_Q (Q.>)) (uncurry (>))+prop_gt = makeProp (uncurryQ (Q.>)) (uncurry (>)) prop_gte :: (Integer, Integer) -> Property-prop_gte = runTest (uncurry_Q (Q.>=)) (uncurry (>=))+prop_gte = makeProp (uncurryQ (Q.>=)) (uncurry (>=)) prop_min_integer :: (Integer,Integer) -> Property-prop_min_integer = runTest (uncurry_Q Q.min) (uncurry min)+prop_min_integer = makeProp (uncurryQ Q.min) (uncurry min) prop_max_integer :: (Integer,Integer) -> Property-prop_max_integer = runTest (uncurry_Q Q.max) (uncurry max)+prop_max_integer = makeProp (uncurryQ Q.max) (uncurry max) prop_min_double :: (Double,Double) -> Property-prop_min_double = runTestDouble (uncurry_Q Q.min) (uncurry min)+prop_min_double = makePropDouble (uncurryQ Q.min) (uncurry min) prop_max_double :: (Double,Double) -> Property-prop_max_double = runTestDouble (uncurry_Q Q.max) (uncurry max)+prop_max_double = makePropDouble (uncurryQ Q.max) (uncurry max) ------------------------------------------------------------------------------------ Lists+-- * Lists +prop_list_1 :: [Integer] -> Property+prop_list_1 = makeProp id id++prop_list_2 :: [[Integer]] -> Property+prop_list_2 = makeProp id id++prop_list_3 :: [[[Integer]]] -> Property+prop_list_3 = makeProp id id+ prop_cons :: (Integer, [Integer]) -> Property-prop_cons = runTest (uncurry_Q (Q.<|)) (uncurry (:))+prop_cons = makeProp (uncurryQ (Q.<|)) (uncurry (:)) prop_snoc :: ([Integer], Integer) -> Property-prop_snoc = runTest (uncurry_Q (Q.|>)) (\(a,b) -> a ++ [b])+prop_snoc = makeProp (uncurryQ (Q.|>)) (\(a,b) -> a ++ [b]) prop_singleton :: Integer -> Property-prop_singleton = runTest Q.singleton (\x -> [x])----- head, tail, last, init, the and index may fail:+prop_singleton = makeProp Q.singleton (\x -> [x]) prop_head :: [Integer] -> Property-prop_head = testNotNull Q.head head+prop_head = makePropNotNull Q.head head prop_tail :: [Integer] -> Property-prop_tail = testNotNull Q.tail tail+prop_tail = makePropNotNull Q.tail tail prop_last :: [Integer] -> Property-prop_last = testNotNull Q.last last+prop_last = makePropNotNull Q.last last prop_init :: [Integer] -> Property-prop_init = testNotNull Q.init init+prop_init = makePropNotNull Q.init init prop_the :: [Integer] -> Property prop_the l = allEqual l- ==> runTest Q.the the l+ ==> makeProp Q.the the l where allEqual [] = False allEqual (x:xs) = all (x ==) xs@@ -366,175 +347,153 @@ prop_index :: ([Integer], Integer) -> Property prop_index (l, i) = i > 0 && i < fromIntegral (length l)- ==> runTest (uncurry_Q (Q.!!))- (\(a,b) -> a !! fromIntegral b)- (l, i)-+ ==> makeProp (uncurryQ (Q.!!))+ (\(a,b) -> a !! fromIntegral b)+ (l, i) prop_take :: (Integer, [Integer]) -> Property-prop_take = runTest (uncurry_Q Q.take) (\(n,l) -> take (fromIntegral n) l)+prop_take = makeProp (uncurryQ Q.take) (\(n,l) -> take (fromIntegral n) l) prop_drop :: (Integer, [Integer]) -> Property-prop_drop = runTest (uncurry_Q Q.drop) (\(n,l) -> drop (fromIntegral n) l)+prop_drop = makeProp (uncurryQ Q.drop) (\(n,l) -> drop (fromIntegral n) l) --- | Map "id" over the list prop_map_id :: [Integer] -> Property-prop_map_id = runTest (Q.map id) (map id)+prop_map_id = makeProp (Q.map id) (map id) prop_append :: ([Integer], [Integer]) -> Property-prop_append = runTest (uncurry_Q (Q.><)) (\(a,b) -> a ++ b)+prop_append = makeProp (uncurryQ (Q.><)) (\(a,b) -> a ++ b) --- | filter "const True" prop_filter_True :: [Integer] -> Property-prop_filter_True = runTest (Q.filter (const $ Q.toQ True)) (filter $ const True)+prop_filter_True = makeProp (Q.filter (const $ Q.toQ True)) (filter $ const True) prop_groupWith_id :: [Integer] -> Property-prop_groupWith_id = runTest (Q.groupWith id) (groupWith id)+prop_groupWith_id = makeProp (Q.groupWith id) (groupWith id) prop_sortWith_id :: [Integer] -> Property-prop_sortWith_id = runTest (Q.sortWith id) (sortWith id)+prop_sortWith_id = makeProp (Q.sortWith id) (sortWith id) prop_null :: [Integer] -> Property-prop_null = runTest Q.null null+prop_null = makeProp Q.null null prop_length :: [Integer] -> Property-prop_length = runTest Q.length (fromIntegral . length)+prop_length = makeProp Q.length (fromIntegral . length) prop_reverse :: [Integer] -> Property-prop_reverse = runTest Q.reverse reverse-------------------------------------------------------------------------------------- Special folds+prop_reverse = makeProp Q.reverse reverse prop_and :: [Bool] -> Property-prop_and = runTest Q.and and+prop_and = makeProp Q.and and prop_or :: [Bool] -> Property-prop_or = runTest Q.or or+prop_or = makeProp Q.or or prop_any_zero :: [Integer] -> Property-prop_any_zero = runTest (Q.any (Q.== 0)) (any (== 0))+prop_any_zero = makeProp (Q.any (Q.== 0)) (any (== 0)) prop_all_zero :: [Integer] -> Property-prop_all_zero = runTest (Q.all (Q.== 0)) (all (== 0))+prop_all_zero = makeProp (Q.all (Q.== 0)) (all (== 0)) prop_sum_integer :: [Integer] -> Property-prop_sum_integer = runTest Q.sum sum+prop_sum_integer = makeProp Q.sum sum prop_sum_double :: [Double] -> Property-prop_sum_double = runTestDouble Q.sum sum+prop_sum_double = makePropDouble Q.sum sum prop_concat :: [[Integer]] -> Property-prop_concat = runTest Q.concat concat+prop_concat = makeProp Q.concat concat prop_concatMap :: [Integer] -> Property-prop_concatMap = runTest (Q.concatMap Q.singleton) (concatMap (\a -> [a]))-+prop_concatMap = makeProp (Q.concatMap Q.singleton) (concatMap (\a -> [a])) prop_maximum :: [Integer] -> Property-prop_maximum = testNotNull Q.maximum maximum+prop_maximum = makePropNotNull Q.maximum maximum prop_minimum :: [Integer] -> Property-prop_minimum = testNotNull Q.minimum minimum------------------------------------------------------------------------------------- Sublists+prop_minimum = makePropNotNull Q.minimum minimum prop_splitAt :: (Integer, [Integer]) -> Property-prop_splitAt = runTest (uncurry_Q Q.splitAt) (\(a,b) -> splitAt (fromIntegral a) b)+prop_splitAt = makeProp (uncurryQ Q.splitAt) (\(a,b) -> splitAt (fromIntegral a) b) prop_takeWhile :: (Integer, [Integer]) -> Property-prop_takeWhile = runTest (uncurry_Q $ Q.takeWhile . (Q.==))+prop_takeWhile = makeProp (uncurryQ $ Q.takeWhile . (Q.==)) (uncurry $ takeWhile . (==)) prop_dropWhile :: (Integer, [Integer]) -> Property-prop_dropWhile = runTest (uncurry_Q $ Q.dropWhile . (Q.==))+prop_dropWhile = makeProp (uncurryQ $ Q.dropWhile . (Q.==)) (uncurry $ dropWhile . (==)) prop_span :: (Integer, [Integer]) -> Property-prop_span = runTest (uncurry_Q $ Q.span . (Q.==))- (uncurry $ span . (==) . fromIntegral)+prop_span = makeProp (uncurryQ $ Q.span . (Q.==))+ (uncurry $ span . (==) . fromIntegral) prop_break :: (Integer, [Integer]) -> Property-prop_break = runTest (uncurry_Q $ Q.break . (Q.==))+prop_break = makeProp (uncurryQ $ Q.break . (Q.==)) (uncurry $ break . (==) . fromIntegral) +prop_elem :: (Integer, [Integer]) -> Property+prop_elem = makeProp (uncurryQ $ Q.elem)+ (uncurry $ elem) ------------------------------------------------------------------------------------ Zipping and unzipping lists+prop_notElem :: (Integer, [Integer]) -> Property+prop_notElem = makeProp (uncurryQ $ Q.notElem)+ (uncurry $ notElem) prop_zip :: ([Integer], [Integer]) -> Property-prop_zip = runTest (uncurry_Q Q.zip) (uncurry zip)+prop_zip = makeProp (uncurryQ Q.zip) (uncurry zip) prop_zipWith_plus :: ([Integer], [Integer]) -> Property-prop_zipWith_plus = runTest (uncurry_Q $ Q.zipWith (+)) (uncurry $ zipWith (+))+prop_zipWith_plus = makeProp (uncurryQ $ Q.zipWith (+)) (uncurry $ zipWith (+)) prop_unzip :: [(Integer, Integer)] -> Property-prop_unzip = runTest Q.unzip unzip-------------------------------------------------------------------------------------- Set operations+prop_unzip = makeProp Q.unzip unzip prop_nub :: [Integer] -> Property-prop_nub = runTest Q.nub nub-+prop_nub = makeProp Q.nub nub ------------------------------------------------------------------------------------ Tuple projection functions+-- * Tuples prop_fst :: (Integer, Integer) -> Property-prop_fst = runTest Q.fst fst+prop_fst = makeProp Q.fst fst prop_snd :: (Integer, Integer) -> Property-prop_snd = runTest Q.snd snd-------------------------------------------------------------------------------------- Conditionals--prop_cond :: Bool -> Property-prop_cond = runTest (Q.cond Q.empty (Q.toQ [0 :: Integer]))- (\b -> if b then [] else [0])+prop_snd = makeProp Q.snd snd ------------------------------------------------------------------------------------ Numerical Operations+-- * Numerics prop_add_integer :: (Integer,Integer) -> Property-prop_add_integer = runTest (uncurry_Q (+)) (uncurry (+))+prop_add_integer = makeProp (uncurryQ (+)) (uncurry (+)) prop_add_double :: (Double,Double) -> Property-prop_add_double = runTestDouble (uncurry_Q (+)) (uncurry (+))+prop_add_double = makePropDouble (uncurryQ (+)) (uncurry (+)) prop_mul_integer :: (Integer,Integer) -> Property-prop_mul_integer = runTest (uncurry_Q (*)) (uncurry (*))+prop_mul_integer = makeProp (uncurryQ (*)) (uncurry (*)) prop_mul_double :: (Double,Double) -> Property-prop_mul_double = runTestDouble (uncurry_Q (*)) (uncurry (*))+prop_mul_double = makePropDouble (uncurryQ (*)) (uncurry (*)) prop_div_double :: (Double,Double) -> Property prop_div_double (x,y) = y /= 0- ==> runTestDouble (uncurry_Q (/)) (uncurry (/)) (x,y)+ ==> makePropDouble (uncurryQ (/)) (uncurry (/)) (x,y) prop_integer_to_double :: Integer -> Property-prop_integer_to_double = runTestDouble Q.integerToDouble fromInteger+prop_integer_to_double = makePropDouble Q.integerToDouble fromInteger prop_abs_integer :: Integer -> Property-prop_abs_integer = runTest Q.abs abs+prop_abs_integer = makeProp Q.abs abs prop_abs_double :: Double -> Property-prop_abs_double = runTestDouble Q.abs abs+prop_abs_double = makePropDouble Q.abs abs prop_signum_integer :: Integer -> Property-prop_signum_integer = runTest Q.signum signum+prop_signum_integer = makeProp Q.signum signum prop_signum_double :: Double -> Property-prop_signum_double = runTestDouble Q.signum signum+prop_signum_double = makePropDouble Q.signum signum prop_negate_integer :: Integer -> Property-prop_negate_integer = runTest Q.negate negate+prop_negate_integer = makeProp Q.negate negate prop_negate_double :: Double -> Property-prop_negate_double = runTestDouble Q.negate negate+prop_negate_double = makePropDouble Q.negate negate