DSH 0.8.1.0 → 0.8.2.0

raw patch · 8 files changed

+245/−80 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• DSH.cabal +2/−2
• examples/Example01.hs +2/−2
• examples/Makefile +2/−1
• src/Database/DSH.hs +2/−2
• src/Database/DSH/Externals.hs +30/−41
• src/Database/DSH/Internals.hs +3/−5
• src/Database/DSH/TH.hs +177/−18
• tests/Main.hs +27/−9

@@ -1,5 +1,5 @@ Name:                DSH-Version:             0.8.1.0+Version:             0.8.2.0 Synopsis:            Database Supported Haskell Description:   This is a Haskell library for database-supported program execution. Using@@ -32,7 +32,7 @@   reading. The package includes a couple of examples that demonstrate how to   use DSH.   .-  This is a highly experimental realise supporting our work-in-progress paper on+  This is a highly experimental release supporting our work-in-progress paper on   "Algebraic Data Types for Language-Integrated Queries".   .   1. <http://db.inf.uni-tuebingen.de/files/giorgidze/ifl2010.pdf>

@@ -12,13 +12,13 @@ ints = toQ [1 .. 10]  query1 :: Q [(Integer,Integer)]-query1 =  [ tuple (i1,i2)+query1 =  [ pair i1 i2           | i1 <- ints           , i2 <- ints           ]  query2 :: Q [(Integer,Integer)]-query2 =  [ tuple (i1,i2)+query2 =  [ pair i1 i2           | (view -> (i1,i2)) <- query1           , i1 == i2           ]

@@ -1,6 +1,7 @@ all: clean 		ghc -Wall -O3 --make Example01.hs+		ghc -Wall -O3 --make Example02.hs 		rm -rf *.hi *.o  clean:-		rm -rf *.hi *.o Example01+		rm -rf *.hi *.o Example01 Example02

@@ -15,7 +15,7 @@  module Database.DSH   ( module Database.DSH.Externals-  , Q, QA, Elim, elim, View, view, fromView+  , Q, QA, Elim, elim, View, view   , module Database.DSH.TH   , module Data.String   , module Data.Text@@ -25,7 +25,7 @@   where  import Database.DSH.Externals-import Database.DSH.Internals (Q,QA,Elim,elim,View,view,fromView)+import Database.DSH.Internals (Q,QA,Elim,elim,View,view) import Database.DSH.TH  import Data.String (IsString,fromString)

@@ -51,12 +51,18 @@   frExp (TextE t) = t   frExp _ = $impossible -instance (QA a, QA b) => QA (a,b) where+instance (QA a,QA b) => QA (a,b) where   type Rep (a,b) = (Rep a,Rep b)   toExp (a,b) = PairE (toExp a) (toExp b)   frExp (PairE a b) = (frExp a,frExp b)   frExp _ = $impossible +instance (QA a,QA b,QA c) => QA (a,b,c) where+  type Rep (a,b,c) = (Rep a,(Rep b,Rep c))+  toExp (a,b,c) = PairE (toExp a) (PairE (toExp b) (toExp c))+  frExp (PairE a (PairE b c)) = (frExp a,frExp b,frExp c)+  frExp _ = $impossible+ instance (QA a) => QA [a] where   type Rep [a] = [Rep a]   toExp as = ListE (P.map toExp as)@@ -194,53 +200,37 @@  -- View instances -instance View (Q ()) (Q ()) where+instance View (Q ()) where   type ToView (Q ()) = Q ()-  type FromView (Q ()) = Q ()   view = id-  fromView = id -instance View (Q Bool) (Q Bool) where+instance View (Q Bool) where   type ToView (Q Bool) = Q Bool-  type FromView (Q Bool) = Q Bool   view = id-  fromView = id -instance View (Q Char) (Q Char) where+instance View (Q Char) where   type ToView (Q Char) = Q Char-  type FromView (Q Char) = Q Char   view = id-  fromView = id -instance View (Q Integer) (Q Integer) where+instance View (Q Integer) where   type ToView (Q Integer) = Q Integer-  type FromView (Q Integer) = Q Integer   view = id-  fromView = id -instance View (Q Double) (Q Double) where+instance View (Q Double) where   type ToView (Q Double) = Q Double-  type FromView (Q Double) = Q Double   view = id-  fromView = id -instance View (Q Text) (Q Text) where+instance View (Q Text) where   type ToView (Q Text) = Q Text-  type FromView (Q Text) = Q Text   view = id-  fromView = id -instance (QA a, QA b) => View (Q (a,b)) (Q a,Q b) where+instance (QA a, QA b) => View (Q (a,b)) where   type ToView (Q (a,b)) = (Q a,Q b)-  type FromView (Q a,Q b) = (Q (a,b))   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+instance (QA a,QA b,QA c) => View (Q (a,b,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 @@ -390,10 +380,10 @@ eitherToPair (Q a) = Q a  left :: (QA a,QA b) => Q a -> Q (Either a b)-left a = pairToEither (tuple (singleton a,nil))+left a = pairToEither (pair (singleton a) nil)  right :: (QA a,QA b) => Q b -> Q (Either a b)-right a = pairToEither (tuple (nil,singleton a))+right a = pairToEither (pair nil (singleton a))  isLeft :: (QA a,QA b) => Q (Either a b) -> Q Bool isLeft = null . snd . eitherToPair@@ -413,7 +403,7 @@ rights = concatMap (snd . eitherToPair)  partitionEithers :: (QA a,QA b) => Q [Either a b] -> Q ([a], [b])-partitionEithers es = tuple (lefts es,rights es)+partitionEithers es = pair (lefts es) (rights es)  -- * List Construction @@ -563,16 +553,16 @@ 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))+zip3 as bs cs = map (\abc -> triple (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)+unzip3 abcs = triple (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 @@ -587,9 +577,6 @@ snd :: (QA a,QA b) => Q (a,b) -> Q b snd (Q e) = Q (AppE Snd e) -pair :: (QA a,QA b) => Q a -> Q b -> Q (a,b)-pair (Q a) (Q b) = Q (PairE a b)- -- * Conversions between numeric types  integerToDouble :: Q Integer -> Q Double@@ -612,13 +599,13 @@ guard :: Q Bool -> Q [()] guard c = cond c (singleton unit) nil --- * Construction of tuples and records+-- * Construction of tuples -tuple :: (View a b) => b -> a-tuple = fromView+pair :: (QA a,QA b) => Q a -> Q b -> Q (a,b)+pair (Q a) (Q b) = Q (PairE a b) -record :: (View a b) => b -> a-record = fromView+triple :: (QA a,QA b,QA c) => Q a -> Q b -> Q c -> Q (a,b,c)+triple (Q a) (Q b) (Q c)= Q (PairE a (PairE b c))  infixl 9  !! infixr 5  ++, <|, |>@@ -627,7 +614,9 @@ infixr 2  || infix  0  ? -deriveTupleRangeQA 3 16+deriveTupleRangeQA                4 7+deriveTupleRangeView              4 7+deriveTupleRangeSmartConstructors 2 7  -- * Missing functions 

@@ -96,12 +96,10 @@  class TA a where -class (ToView a ~ b, FromView b ~ a) => View a b where+class View a where   type ToView a-  type FromView b-  view :: a -> b-  fromView :: b -> a-+  view :: a -> ToView a+  -- Show instances  instance Show (Type a) where

@@ -1,10 +1,19 @@-module Database.DSH.TH (deriveDSH, deriveQA, deriveTupleRangeQA, deriveElim) where+module Database.DSH.TH ( deriveDSH+                       , deriveQA+                       , deriveTupleRangeQA+                       , deriveView+                       , deriveTupleRangeView+                       , deriveElim+                       , deriveSmartConstructors+                       , deriveTupleRangeSmartConstructors+                       ) where  import qualified Database.DSH.Internals  as DSH import qualified Database.DSH.Impossible as DSH  import Language.Haskell.TH import Control.Monad+import Data.Char  ----------------------------------------- -- Deriving all DSH-relevant instances --@@ -12,9 +21,14 @@  deriveDSH :: Name -> Q [Dec] deriveDSH n = do-  qa <- deriveQA n-  el <- deriveElim n-  return (qa ++ el)+  qaDecs    <- deriveQA n+  elimDecs  <- deriveElim n+  cc        <- countConstructors n+  viewDecs  <- if cc == 1+                  then deriveView n+                  else return []+  scDecs    <- deriveSmartConstructors n+  return (qaDecs ++ elimDecs ++ viewDecs ++ scDecs)  ----------------- -- Deriving QA --@@ -24,13 +38,19 @@ deriveQA name = do   info <- reify name   case info of-    TyConI (DataD    _cxt name1 tyVarBndrs cons _names) -> deriveTyConQA name1 tyVarBndrs cons-    TyConI (NewtypeD _cxt name1 tyVarBndrs con  _names) -> deriveTyConQA name1 tyVarBndrs [con]-    _                                                   -> fail errMsgExoticType+    TyConI (DataD    _cxt name1 tyVarBndrs cons _names) ->+      deriveTyConQA name1 tyVarBndrs cons+    TyConI (NewtypeD _cxt name1 tyVarBndrs con  _names) ->+      deriveTyConQA name1 tyVarBndrs [con]+    _ -> fail errMsgExoticType +deriveTupleRangeQA :: Int -> Int -> Q [Dec]+deriveTupleRangeQA x y = fmap concat (mapM (deriveQA . tupleTypeName) [x .. y])+ deriveTyConQA :: Name -> [TyVarBndr] -> [Con] -> Q [Dec] deriveTyConQA name tyVarBndrs cons = do-  let context       = map (\tv -> ClassP ''DSH.QA [VarT (tyVarBndrToName tv)]) tyVarBndrs+  let context       = map (\tv -> ClassP ''DSH.QA [VarT (tyVarBndrToName tv)])+                          tyVarBndrs   let typ           = foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs)   let instanceHead  = AppT (ConT ''DSH.QA) typ   let repDec        = deriveRep typ cons@@ -38,9 +58,6 @@   frExpDec <- deriveFrExp cons   return [InstanceD context instanceHead [repDec,toExpDec,frExpDec]] -deriveTupleRangeQA :: Int -> Int -> Q [Dec]-deriveTupleRangeQA x y = fmap concat (mapM (deriveQA . tupleTypeName) [x .. y])- -- Deriving the Rep type function  deriveRep :: Type -> [Con] -> Dec@@ -81,7 +98,9 @@   let exp1 = deriveToExpMainExp names1   expList1 <- [| DSH.ListE [ $(return exp1) ] |]   expEmptyList <- [| DSH.ListE [] |]-  let lists = replicate i expEmptyList ++ [expList1] ++ replicate (n - i - 1) expEmptyList+  let lists = concat [ replicate i expEmptyList+                     , [expList1]+                     , replicate (n - i - 1) expEmptyList]   let exp2 = foldr1 (AppE . AppE (ConE 'DSH.PairE)) lists   let body1 = NormalB exp2   return (Clause [pat1] body1 [])@@ -107,7 +126,9 @@ deriveFrExpClause 1 _ con = do   (_,names1) <- conToPattern con   let pat1 = deriveFrExpMainPat names1-  let exp1 = foldl AppE (ConE (conToName con)) (map (AppE (VarE 'DSH.frExp) . VarE) names1)+  let exp1 = foldl AppE+                   (ConE (conToName con))+                   (map (AppE (VarE 'DSH.frExp) . VarE) names1)   let body1 = NormalB exp1   return (Clause [pat1] body1 []) deriveFrExpClause n i con = do@@ -116,7 +137,9 @@   let patList1 = ConP 'DSH.ListE [ConP '(:) [pat1,WildP]]   let lists = replicate i WildP ++ [patList1] ++ replicate (n - i - 1) WildP   let pat2 = foldr1 (\p1 p2 -> ConP 'DSH.PairE [p1,p2]) lists-  let exp1 = foldl AppE (ConE (conToName con)) (map (AppE (VarE 'DSH.frExp) . VarE) names1)+  let exp1 = foldl AppE+                   (ConE (conToName con))+                   (map (AppE (VarE 'DSH.frExp) . VarE) names1)   let body1 = NormalB exp1   return (Clause [pat2] body1 []) @@ -126,6 +149,53 @@ deriveFrExpMainPat names  = foldr1 (\p1 p2 -> ConP 'DSH.PairE [p1,p2]) (map VarP names)  -------------------+-- Deriving View --+-------------------++deriveView :: Name -> Q [Dec]+deriveView name = do+  info <- reify name+  case info of+    TyConI (DataD    _cxt name1 tyVarBndrs [con] _names) ->+      deriveTyConView name1 tyVarBndrs con+    TyConI (NewtypeD _cxt name1 tyVarBndrs con  _names) ->+      deriveTyConView name1 tyVarBndrs con+    _ -> fail errMsgExoticType++deriveTupleRangeView :: Int -> Int -> Q [Dec]+deriveTupleRangeView x y = fmap concat (mapM (deriveView . tupleTypeName) [x .. y])++deriveTyConView :: Name -> [TyVarBndr] -> Con -> Q [Dec]+deriveTyConView name tyVarBndrs con = do+  let context = map (\tv -> ClassP ''DSH.QA [VarT (tyVarBndrToName tv)]) tyVarBndrs+  let typ1 = AppT (ConT ''DSH.Q)+                  (foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs))+  let instanceHead = AppT (ConT ''DSH.View) typ1+  let typs = conToTypes con+  let typ2 = if null typs+                then AppT (ConT ''DSH.Q) (ConT ''())+                else foldl AppT (TupleT (length typs)) (map (AppT (ConT ''DSH.Q)) typs)+  let toViewDecTF = TySynInstD ''DSH.ToView [typ1] typ2+  viewDec <- deriveToView (length typs)+  return [InstanceD context instanceHead [toViewDecTF, viewDec]]++deriveToView :: Int -> Q Dec+deriveToView n = do+  en <- newName "e"+  let ep = VarP en+  let pat1 = ConP 'DSH.Q [ep]++  let fAux 0  e1 = [AppE (ConE 'DSH.Q) e1]+      fAux 1  e1 = [AppE (ConE 'DSH.Q) e1]+      fAux n1 e1 = let fste = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Fst)) e1+                       snde = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Snd)) e1+                   in  AppE (ConE 'DSH.Q) fste : fAux (n1 - 1) snde++  let body1 = TupE (fAux n (VarE en))+  let clause1 = Clause [pat1] (NormalB body1) []+  return (FunD 'DSH.view [clause1])++------------------- -- Deriving Elim -- ------------------- @@ -133,8 +203,10 @@ deriveElim name = do   info <- reify name   case info of-    TyConI (DataD    _cxt name1 tyVarBndrs cons _names) -> deriveTyConElim name1 tyVarBndrs cons-    TyConI (NewtypeD _cxt name1 tyVarBndrs con  _names) -> deriveTyConElim name1 tyVarBndrs [con]+    TyConI (DataD    _cxt name1 tyVarBndrs cons _names) ->+      deriveTyConElim name1 tyVarBndrs cons+    TyConI (NewtypeD _cxt name1 tyVarBndrs con  _names) ->+      deriveTyConElim name1 tyVarBndrs [con]     _ -> fail errMsgExoticType  deriveTyConElim :: Name -> [TyVarBndr] -> [Con] -> Q [Dec]@@ -152,7 +224,8 @@ -- Deriving the Eliminator type function  deriveEliminator :: Type -> Type -> [Con] -> Dec-deriveEliminator typ resTy cons = TySynInstD ''DSH.Eliminator [typ,resTy] (deriveEliminatorCons resTy cons)+deriveEliminator typ resTy cons =+  TySynInstD ''DSH.Eliminator [typ,resTy] (deriveEliminatorCons resTy cons)  deriveEliminatorCons :: Type -> [Con] -> Type deriveEliminatorCons _ []  = error errMsgExoticType@@ -229,6 +302,81 @@         mape  = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Map)) paire     in  mape : go snde fs1 +---------------------------------+-- Deriving Smart Constructors --+---------------------------------++deriveSmartConstructors :: Name -> Q [Dec]+deriveSmartConstructors name = do+  info <- reify name+  case info of+    TyConI (DataD    _cxt typConName tyVarBndrs cons _names) -> do+      decss <- zipWithM (deriveSmartConstructor typConName tyVarBndrs (length cons))+                        [0 .. ]+                        cons+      return (concat decss)+    TyConI (NewtypeD _cxt typConName tyVarBndrs con  _names) ->+      deriveSmartConstructor typConName tyVarBndrs 1 0 con+    _ -> fail errMsgExoticType++deriveTupleRangeSmartConstructors :: Int -> Int -> Q [Dec]+deriveTupleRangeSmartConstructors x y =+  fmap concat (mapM (deriveSmartConstructors . tupleTypeName) [x .. y])++deriveSmartConstructor :: Name -> [TyVarBndr] -> Int -> Int -> Con -> Q [Dec]+deriveSmartConstructor typConName tyVarBndrs n i con = do+  let smartConName = toSmartConName (conToName con)+  +  let boundTyps = map (VarT . tyVarBndrToName) tyVarBndrs++  let resTyp = AppT (ConT ''DSH.Q) (foldl AppT (ConT typConName) boundTyps)++  let smartConContext = map (ClassP ''DSH.QA . return) boundTyps+  +  let smartConTyp = foldr (AppT . AppT ArrowT . AppT (ConT ''DSH.Q))+                          resTyp+                          (conToTypes con)+  +  let smartConDec = SigD smartConName (ForallT tyVarBndrs smartConContext smartConTyp)++  ns <- mapM (\_ -> newName "e") (conToTypes con)+  let es = map VarE ns+  +  let smartConPat = map (ConP 'DSH.Q . return . VarP) ns+  +  let smartConExp = if null es+                       then (ConE 'DSH.UnitE)+                       else foldr1 (AppE . AppE (ConE 'DSH.PairE)) es+  smartConBody <- deriveSmartConBody n i smartConExp+  let smartConClause = Clause smartConPat (NormalB smartConBody) []+  +  let funDec = FunD smartConName [smartConClause]+  +  return [smartConDec,funDec]++deriveSmartConBody :: Int -- Total number of constructors+                   -> Int -- Index of the constructor+                   -> Exp+                   -> Q Exp+deriveSmartConBody 0 _ _ = fail errMsgExoticType+deriveSmartConBody 1 _ e = return (AppE (ConE 'DSH.Q) e)+deriveSmartConBody n i e = do+  listExp <- [| DSH.ListE [ $(return e) ] |]+  emptyListExp <- [| DSH.ListE [] |]+  let lists = concat [ replicate i emptyListExp+                     , [listExp]+                     , replicate (n - i - 1) emptyListExp+                     ]+  let pairExp = foldr1 (AppE . AppE (ConE 'DSH.PairE)) lists+  return (AppE (ConE 'DSH.Q) pairExp)++toSmartConName :: Name -> Name+toSmartConName name1 = case nameBase name1 of+  "()"                -> mkName "unit"+  '(' : cs            -> mkName ("tuple" ++ show (length (filter (== ',') cs) + 1))+  c : cs | isAlpha c  -> mkName (toLower c : cs)+  cs                  -> mkName (':' : cs)+ -- Helper Functions  conToTypes :: Con -> [Type]@@ -259,7 +407,18 @@ conToName (InfixC _ name _) = name conToName (ForallC _ _ con)	= conToName con +countConstructors :: Name -> Q Int+countConstructors name = do+  info <- reify name+  case info of+    TyConI (DataD    _ _ _ cons _)  -> return (length cons)+    TyConI (NewtypeD {})            -> return 1+    _ -> fail errMsgExoticType+ -- Error messages  errMsgExoticType :: String-errMsgExoticType =  "Automatic derivation of DSH related type class instances only works for Haskell 98 types."+errMsgExoticType =+  "Automatic derivation of DSH related type class instances only works for Haskell 98\+   \ types. Derivation of View patters is only supported for single-constructor data\+   \ types."

@@ -30,26 +30,34 @@ instance Arbitrary Text where   arbitrary = fmap Text.pack arbitrary -data D1 = C11 deriving (Eq,Ord,Show)+data D0 = C01 deriving (Eq,Ord,Show)+derive makeArbitrary ''D0+Q.deriveDSH ''D0++data D1 a = C11 a deriving (Eq,Ord,Show) derive makeArbitrary ''D1 Q.deriveDSH ''D1 -data D2 = C21 | C22 deriving (Eq,Ord,Show)+data D2 a b = C21 a b b a deriving (Eq,Ord,Show) derive makeArbitrary ''D2 Q.deriveDSH ''D2 -data D3 a = C31 a | C32 deriving (Eq,Ord,Show)+data D3 = C31 | 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)+data D4 a = C41 a | C42 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)+data D5 a = C51 a | C52 | C53 a a | C54 a a a deriving (Eq,Ord,Show) derive makeArbitrary ''D5 Q.deriveDSH ''D5 +data D6 a b c d e = C61 { c611 :: a, c612 :: (a,b,c,d) } | C62 | C63 a b | C64 (a,b,c) | C65 a b c d e deriving (Eq,Ord,Show)+derive makeArbitrary ''D6+Q.deriveDSH ''D6+ getConn :: IO Connection getConn = connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'" @@ -85,6 +93,8 @@     qc prop_maybe_integer     putStrPad "Either Integer Integer: "     qc prop_either_integer+    putStrPad "D0: "+    qc prop_d0     putStrPad "D1: "     qc prop_d1     putStrPad "D2: "@@ -95,6 +105,8 @@     qc prop_d4     putStrPad "D5: "     qc prop_d5+    putStrPad "D6: "+    qc prop_d6      putStrLn ""     putStrLn "Equality, Boolean Logic and Ordering"@@ -366,20 +378,26 @@ prop_either_integer :: Either Integer Integer -> Property prop_either_integer = makeProp id id -prop_d1 :: D1 -> Property+prop_d0 :: D0 -> Property+prop_d0 = makeProp id id++prop_d1 :: D1 Integer -> Property prop_d1 = makeProp id id -prop_d2 :: D2 -> Property+prop_d2 :: D2 Integer Integer -> Property prop_d2 = makeProp id id -prop_d3 :: D3 Integer -> Property+prop_d3 :: D3 -> 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 :: D5 Integer -> Property prop_d5 = makeProp id id++prop_d6 :: D6 Integer Integer Integer Integer Integer -> Property+prop_d6 = makeProp id id  -- * Equality, Boolean Logic and Ordering