diff --git a/DSH.cabal b/DSH.cabal --- a/DSH.cabal +++ b/DSH.cabal @@ -1,5 +1,5 @@ Name: DSH -Version: 0.5.3 +Version: 0.5.5 Synopsis: Database Supported Haskell Description: This is a Haskell library for database-supported program execution. Using @@ -65,8 +65,8 @@ syntax-trees >= 0.1.2, HaXml >= 1.20, csv >= 0.1, - Pathfinder >= 0.5, - FerryCore >= 0.4 + Pathfinder >= 0.5.6, + FerryCore >= 0.4.6.1 Hs-Source-Dirs: src diff --git a/src/Database/DSH.hs b/src/Database/DSH.hs --- a/src/Database/DSH.hs +++ b/src/Database/DSH.hs @@ -90,10 +90,12 @@ , break , elem , notElem + , lookup , zip , zipWith , unzip , fst , snd , maybe + , either ) diff --git a/src/Database/DSH/Combinators.hs b/src/Database/DSH/Combinators.hs --- a/src/Database/DSH/Combinators.hs +++ b/src/Database/DSH/Combinators.hs @@ -8,7 +8,7 @@ import Data.Convertible -import Prelude (Eq, Ord, Num, Bool(..), Integer, Double, Maybe, undefined, error, ($)) +import Prelude (Eq, Ord, Num, Bool(..), Integer, Double, Maybe, Either, undefined, error, ($), (.)) -- * Unit @@ -121,11 +121,37 @@ fromMaybe a ma = (isNothing ma) ? (a, fromJust (ma)) catMaybes :: QA a => Q [Maybe a] -> Q [a] -catMaybes mas = map fromJust (filter isJust mas) +catMaybes mas = concatMap maybeToList mas mapMaybe :: (QA a, QA b) => (Q a -> Q (Maybe b)) -> Q [a] -> Q [b] -mapMaybe f as = catMaybes (map f as) +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] @@ -261,6 +287,9 @@ 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)] @@ -343,10 +372,6 @@ > words > unlines > unwords - -Searching lists: - -> lookup Zipping and unzipping lists: diff --git a/src/Database/DSH/Data.hs b/src/Database/DSH/Data.hs --- a/src/Database/DSH/Data.hs +++ b/src/Database/DSH/Data.hs @@ -84,8 +84,8 @@ TableDB String [[String]] | TableCSV String deriving (Eq, Ord, Show, Data, Typeable) - - + + typeExp :: Exp -> Type typeExp e = case e of UnitE t -> t @@ -174,13 +174,33 @@ fromNorm _ = $impossible instance (QA a) => QA (Maybe a) where - reify _ = ListT (reify (undefined :: a)) - toNorm Nothing = ListN [] (ListT (reify (undefined :: a))) - toNorm (Just x) = ListN [toNorm x] (ListT (reify (undefined :: a))) - fromNorm (ListN [] (ListT _)) = Nothing - fromNorm (ListN (x : _) (ListT _)) = Just (fromNorm x) - fromNorm _ = $impossible + reify _ = reify ([] :: [a]) + toNorm Nothing = toNorm ([] :: [a]) + toNorm (Just x) = toNorm [x] + + fromNorm ma = case (fromNorm ma) :: [a] of + [] -> Nothing + (x : _) -> Just x + +instance (QA a,QA b) => QA (Either a b) where + reify _ = reify (([],[]) :: ([a],[b])) + + toNorm (Left x) = toNorm ([x],[] :: [b]) + toNorm (Right x) = toNorm ([] :: [a],[x]) + + fromNorm e = case (fromNorm e) :: ([a],[b]) of + ([],x : _) -> Right x + (x : _,[]) -> Left x + _ -> $impossible + + +tupleToEither :: (QA a,QA b) => Q ([a],[b]) -> Q (Either a b) +tupleToEither (Q x) = (Q x) + +eitherToTuple :: (QA a,QA b) => Q (Either a b) -> Q ([a],[b]) +eitherToTuple (Q x) = (Q x) + class BasicType a where instance BasicType () where @@ -437,7 +457,7 @@ TextN t _ -> Right $ SqlString $ T.unpack t ListN _ _ -> convError "Cannot convert `Norm' to `SqlValue'" n TupleN _ _ _ -> convError "Cannot convert `Norm' to `SqlValue'" n - - + + instance IsString (Q Text) where fromString s = Q (TextE (T.pack s) TextT) diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -16,6 +16,7 @@ import Data.List import Data.Maybe +import Data.Either import GHC.Exts import Data.Text (Text) @@ -30,204 +31,232 @@ getConn = connectPostgreSQL "user = 'postgres' password = 'haskell98' host = 'localhost' dbname = 'ferry'" qc:: Testable prop => prop -> IO () -qc = quickCheckWith stdArgs{maxSuccess = 100, maxSize = 10} +qc = quickCheckWith stdArgs{maxSuccess = 100, maxSize = 5} +putStrPad :: String -> IO () +putStrPad s = putStr (s ++ replicate (32 - length s) ' ' ) + main :: IO () main = do putStrLn "Supprted Types" putStrLn "--------------" - putStr "(): " + putStrPad "()" qc prop_unit - putStr "Bool: " + putStrPad "Bool" qc prop_bool - putStr "Char: " + putStrPad "Char" qc prop_char - putStr "Text: " + putStrPad "Text" qc prop_text - putStr "Integer: " + putStrPad "Integer" qc prop_integer - putStr "Double: " + putStrPad "Double" qc prop_double - putStr "[Integer]: " + putStrPad "[Integer]" qc prop_list_integer_1 - putStr "[[Integer]]: " + putStrPad "[[Integer]]" qc prop_list_integer_2 - putStr "[[[Integer]]]: " + putStrPad "[[[Integer]]]" qc prop_list_integer_3 - putStr "Maybe Integer: " + putStrPad "Maybe Integer" qc prop_maybe_integer - - + putStrPad "Either Integer Integer: " + qc prop_either_integer + putStrLn "" putStrLn "Equality, Boolean Logic and Ordering" putStrLn "------------------------------------" - putStr "&&: " + putStrPad "&&" qc prop_infix_and - putStr "||: " + putStrPad "||" qc prop_infix_or - putStr "not: " + putStrPad "not" qc prop_not - putStr "eq: " + putStrPad "eq" qc prop_eq - putStr "neq: " + putStrPad "neq" qc prop_neq - putStr "cond: " + putStrPad "cond" qc prop_cond - putStr "lt: " + putStrPad "lt" qc prop_lt - putStr "lte: " + putStrPad "lte" qc prop_lte - putStr "gt: " + putStrPad "gt" qc prop_gt - putStr "gte: " + putStrPad "gte" qc prop_gte - putStr "min_integer: " + putStrPad "min_integer" qc prop_min_integer - putStr "min_double: " + putStrPad "min_double" qc prop_min_double - putStr "max_integer: " + putStrPad "max_integer" qc prop_max_integer - putStr "max_double: " + putStrPad "max_double" qc prop_max_double putStrLn "" putStrLn "Tuples" putStrLn "------" - putStr "fst: " + putStrPad "fst" qc prop_fst - putStr "snd: " + putStrPad "snd" qc prop_snd putStrLn "" putStrLn "Numerics:" putStrLn "-----------" - putStr "add_integer: " + putStrPad "add_integer" qc prop_add_integer - putStr "add_double: " + putStrPad "add_double" qc prop_add_double - putStr "mul_integer: " + putStrPad "mul_integer" qc prop_mul_integer - putStr "mul_double: " + putStrPad "mul_double" qc prop_mul_double - putStr "div_double: " + putStrPad "div_double" qc prop_div_double - putStr "integer_to_double: " + putStrPad "integer_to_double: " qc prop_integer_to_double - putStr "abs_integer: " + putStrPad "abs_integer" qc prop_abs_integer - putStr "abs_double: " + putStrPad "abs_double" qc prop_abs_double - putStr "signum_integer: " + putStrPad "signum_integer: " qc prop_signum_integer - putStr "signum_double: " + putStrPad "signum_double" qc prop_signum_double - putStr "negate_integer: " + putStrPad "negate_integer: " qc prop_negate_integer - putStr "negate_double: " + putStrPad "negate_double" qc prop_negate_double - + putStrLn "" putStrLn "Maybe" putStrLn "-----" - putStr "maybe: " + putStrPad "maybe" qc prop_maybe - putStr "isJust: " + putStrPad "just" + qc prop_just + putStrPad "isJust" qc prop_isJust - putStr "isNothing: " + putStrPad "isNothing" qc prop_isNothing - putStr "fromJust: " + putStrPad "fromJust" qc prop_fromJust - putStr "fromMaybe: " + putStrPad "fromMaybe" qc prop_fromMaybe - putStr "listToMaybe: " + putStrPad "listToMaybe" qc prop_listToMaybe - putStr "maybeToList: " + putStrPad "maybeToList" qc prop_maybeToList - putStr "catMaybes: " + putStrPad "catMaybes" qc prop_catMaybes - putStr "mapMaybe: " + putStrPad "mapMaybe" qc prop_mapMaybe - + putStrLn "" + putStrLn "Either" + putStrLn "-----" + putStrPad "left" + qc prop_left + putStrPad "right" + qc prop_right + putStrPad "isLeft" + qc prop_isLeft + putStrPad "isRight" + qc prop_isRight + putStrPad "either" + qc prop_either + putStrPad "lefts" + qc prop_lefts + putStrPad "rights" + qc prop_rights + putStrPad "partitionEithers" + qc prop_partitionEithers + + putStrLn "" putStrLn "Lists" putStrLn "-----" - putStr "head: " + putStrPad "head" qc prop_head - putStr "tail: " + putStrPad "tail" qc prop_tail - putStr "cons: " + putStrPad "cons" qc prop_cons - putStr "snoc: " + putStrPad "snoc" qc prop_snoc - putStr "take: " + putStrPad "take" qc prop_take - putStr "drop: " + putStrPad "drop" qc prop_drop - putStr "map: " + putStrPad "map" qc prop_map - putStr "filter: " + putStrPad "filter" qc prop_filter - putStr "the: " + putStrPad "the" qc prop_the - putStr "last: " + putStrPad "last" qc prop_last - putStr "init: " + putStrPad "init" qc prop_init - putStr "null: " + putStrPad "null" qc prop_null - putStr "length: " + putStrPad "length" qc prop_length - putStr "index: " + putStrPad "index" qc prop_index - putStr "reverse: " + putStrPad "reverse" qc prop_reverse - putStr "append: " + putStrPad "append" qc prop_append - putStr "groupWith: " + putStrPad "groupWith" qc prop_groupWith - putStr "sortWith: " + putStrPad "sortWith" qc prop_sortWith - putStr "and: " + putStrPad "and" qc prop_and - putStr "or: " + putStrPad "or" qc prop_or - putStr "any_zero: " + putStrPad "any_zero" qc prop_any_zero - putStr "all_zero: " + putStrPad "all_zero" qc prop_all_zero - putStr "sum_integer: " + putStrPad "sum_integer" qc prop_sum_integer - putStr "sum_double: " + putStrPad "sum_double" qc prop_sum_double - putStr "concat: " + putStrPad "concat" qc prop_concat - putStr "concatMap: " + putStrPad "concatMap" qc prop_concatMap - putStr "maximum: " + putStrPad "maximum" qc prop_maximum - putStr "minimum: " + putStrPad "minimum" qc prop_minimum - putStr "splitAt: " + putStrPad "splitAt" qc prop_splitAt - putStr "takeWhile: " + putStrPad "takeWhile" qc prop_takeWhile - putStr "dropWhile: " + putStrPad "dropWhile" qc prop_dropWhile - putStr "span: " + putStrPad "span" qc prop_span - putStr "break: " + putStrPad "break" qc prop_break - putStr "elem: " + putStrPad "elem" qc prop_elem - putStr "notElem: " + putStrPad "notElem" qc prop_notElem - putStr "zip: " + putStrPad "lookup" + qc prop_lookup + putStrPad "zip" qc prop_zip - putStr "zipWith: " + putStrPad "zipWith" qc prop_zipWith - putStr "unzip: " + putStrPad "unzip" qc prop_unzip - putStr "nub: " + putStrPad "nub" qc prop_nub makeProp :: (Eq b, QA a, QA b, Show a, Show b) @@ -297,6 +326,9 @@ prop_maybe_integer :: Maybe Integer -> Property prop_maybe_integer = makeProp id id +prop_either_integer :: Either Integer Integer -> Property +prop_either_integer = makeProp id id + -- * Equality, Boolean Logic and Ordering prop_infix_and :: (Bool,Bool) -> Property @@ -346,6 +378,9 @@ prop_maybe :: (Integer, Maybe Integer) -> Property prop_maybe = makeProp (\a -> Q.maybe (Q.fst a) id (Q.snd a)) (\(i,mi) -> maybe i id mi) +prop_just :: Integer -> Property +prop_just = makeProp Q.just Just + prop_isJust :: Maybe Integer -> Property prop_isJust = makeProp Q.isJust isJust @@ -370,6 +405,32 @@ prop_mapMaybe :: [Maybe Integer] -> Property prop_mapMaybe = makeProp (Q.mapMaybe id) (mapMaybe id) +-- * Either + +prop_left :: Integer -> Property +prop_left = makeProp (Q.left :: Q Integer -> Q (Either Integer Integer)) Left + +prop_right :: Integer -> Property +prop_right = makeProp (Q.right :: Q Integer -> Q (Either Integer Integer)) Right + +prop_isLeft :: Either Integer Integer -> Property +prop_isLeft = makeProp Q.isLeft (\e -> case e of {Left _ -> True; Right _ -> False;}) + +prop_isRight :: Either Integer Integer -> Property +prop_isRight = makeProp Q.isRight (\e -> case e of {Left _ -> False; Right _ -> True;}) + +prop_either :: (Either Integer Integer) -> Property +prop_either = makeProp (Q.either id id) (either id id) + +prop_lefts :: [Either Integer Integer] -> Property +prop_lefts = makeProp Q.lefts lefts + +prop_rights :: [Either Integer Integer] -> Property +prop_rights = makeProp Q.rights rights + +prop_partitionEithers :: [Either Integer Integer] -> Property +prop_partitionEithers = makeProp Q.partitionEithers partitionEithers + -- * Lists prop_cons :: (Integer, [Integer]) -> Property @@ -489,11 +550,15 @@ prop_elem :: (Integer, [Integer]) -> Property prop_elem = makeProp (uncurryQ $ Q.elem) - (uncurry $ elem) + (uncurry $ elem) prop_notElem :: (Integer, [Integer]) -> Property prop_notElem = makeProp (uncurryQ $ Q.notElem) - (uncurry $ notElem) + (uncurry $ notElem) + +prop_lookup :: (Integer, [(Integer,Integer)]) -> Property +prop_lookup = makeProp (uncurryQ $ Q.lookup) + (uncurry $ lookup) prop_zip :: ([Integer], [Integer]) -> Property prop_zip = makeProp (uncurryQ Q.zip) (uncurry zip)