DSH 0.7.8.2 → 0.8.0.1

raw patch · 18 files changed

+1757/−2233 lines, 18 filesdep −convertibledep −jsondep −sybdep ~FerryCoredep ~HDBCdep ~HaXmlPVP ok

version bump matches the API change (PVP)

Dependencies removed: convertible, json, syb, xhtml

Dependency ranges changed: FerryCore, HDBC, HaXml, Pathfinder, array, base, bytestring, containers, csv, mtl, template-haskell, text

API changes (from Hackage documentation)

Files

• DSH.cabal +31/−27
• examples/Example02.hs +0/−14
• examples/Makefile +1/−2
• src/Database/DSH.hs +6/−31
• src/Database/DSH/CSV.hs +21/−65
• src/Database/DSH/Combinators.hs +0/−398
• src/Database/DSH/Compile.hs +77/−40
• src/Database/DSH/Compiler.hs +190/−192
• src/Database/DSH/Data.hs +0/−463
• src/Database/DSH/Externals.hs +647/−0
• src/Database/DSH/Impossible.hs +1/−1
• src/Database/DSH/Internals.hs +204/−0
• src/Database/DSH/Interpreter.hs +341/−350
• src/Database/DSH/JSON.hs +0/−33
• src/Database/DSH/TH.hs +216/−546
• src/Database/DSH/XHTML.hs +0/−47
• tests/Main.hs +20/−22
• tests/Makefile +2/−2

@@ -1,5 +1,5 @@ Name:                DSH-Version:             0.7.8.2+Version:             0.8.0.1 Synopsis:            Database Supported Haskell Description:   This is a Haskell library for database-supported program execution. Using@@ -32,6 +32,9 @@   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+  "Algebraic Data Types for Language-Integrated Queries".+  .   1. <http://db.inf.uni-tuebingen.de/files/giorgidze/ifl2010.pdf>  License:             BSD3@@ -43,44 +46,45 @@ Build-type:          Simple  Extra-source-files:  examples/Example01.hs-                     examples/Example02.hs                      examples/Makefile                      tests/Main.hs                      tests/Makefile -Cabal-version:       >= 1.2+Cabal-version:       >= 1.4  Library-  Build-depends:     base               >= 4.3.1.0 && < 5,-                     containers         >= 0.4.0.0,-                     array              >= 0.3.0.2,-                     syb                >= 0.3,-                     mtl                >= 2.0.1.0,-                     bytestring         >= 0.9.1.10,-                     text               >= 0.11.0.6,-                     HDBC               >= 2.3.1.0,-                     convertible        >= 1.0.11.0,-                     template-haskell   >= 2.5.0.0,-                     HaXml              >= 1.22.5,-                     csv                >= 0.1.2,-                     json               >= 0.5,-                     xhtml              >= 3000.2.0.1,-                     Pathfinder         >= 0.5.10,-                     FerryCore          >= 0.4.6.4+  Extensions:        TemplateHaskell,+                     ScopedTypeVariables,+                     FlexibleContexts,+                     FlexibleInstances,+                     MultiParamTypeClasses,+                     TypeFamilies,+                     GADTs +  Build-depends:     base               >= 4.5 && < 5,+                     containers         >= 0.4,+                     array              >= 0.4,+                     bytestring         >= 0.9,+                     template-haskell   >= 2.7,+                     mtl                >= 2.1,+                     text               >= 0.11,+                     HDBC               >= 2.3,+                     HaXml              >= 1.23,+                     csv                >= 0.1,+                     Pathfinder         >= 0.5,+                     FerryCore          >= 0.4+   Hs-source-dirs:    src -  GHC-options:       -O3 -Wall+  GHC-options:       -O3 -Wall -fno-warn-orphans -  Exposed-modules:   Database.DSH-                     Database.DSH.Interpreter+  Exposed-modules:   Database.DSH.Interpreter                      Database.DSH.Compiler+                     Database.DSH -  Other-modules:     Database.DSH.TH-                     Database.DSH.Data-                     Database.DSH.Combinators+  Other-modules:     Database.DSH.Internals+                     Database.DSH.Externals                      Database.DSH.CSV-                     Database.DSH.JSON-                     Database.DSH.XHTML                      Database.DSH.Impossible                      Database.DSH.Compile+                     Database.DSH.TH

@@ -1,14 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses #-}--module Main where--import qualified Prelude as P-import Database.DSH--import Database.HDBC.PostgreSQL-          -$(generateDatabaseRecordInstances (connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'"))-$(generateTableDeclarations       (connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'"))--main :: IO ()-main = P.return ()

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

@@ -14,27 +14,8 @@ -- by Database.DSH.  module Database.DSH-  (-    module Database.DSH.Combinators--    -- * Data Types-  , Q--    -- * Type Classes-  , QA-  , TA, table, tableDB, tableCSV, tableWithKeys, BasicType-  , View, view, fromView, tuple, record--    -- * Template Haskell: Creating Table Representations-  , generateDatabaseRecordInstances-  , generateTableRecordInstances-  , generateRecordInstances-  , generateTableDeclarations--  , module Database.DSH.CSV-  , module Database.DSH.JSON-  , module Database.DSH.XHTML-+  ( module Database.DSH.Externals+  , Q, QA, Elim, elim, View, view, fromView   , module Data.String   , module Data.Text   , module Database.HDBC@@ -42,19 +23,12 @@   )   where -import Database.DSH.Data (Q, QA, TA, table, tableDB, tableCSV, tableWithKeys, BasicType, View, view, fromView, tuple, record)-import Database.DSH.TH (generateDatabaseRecordInstances, generateTableRecordInstances, generateRecordInstances, generateTableDeclarations)--import Database.DSH.CSV-import Database.DSH.JSON-import Database.DSH.XHTML--import Database.DSH.Combinators+import Database.DSH.Externals+import Database.DSH.Internals (Q,QA,Elim,elim,View,view,fromView) -import Data.String(IsString,fromString)+import Data.String (IsString,fromString) import Data.Text (Text) import Database.HDBC- import Prelude hiding (     not   , (&&)@@ -78,6 +52,7 @@   , null   , length   , (!!)+  , (++)   , reverse   , and   , or

@@ -1,83 +1,39 @@-{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}--module Database.DSH.CSV (csvImport, csvExport, csvExportHandle, csvExportStdout) where+module Database.DSH.CSV (csvImport) where -import Database.DSH.Data-import Database.DSH.Impossible+import Database.DSH.Internals -import Text.CSV-import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.IO as T--import qualified System.IO as IO-import System.IO (Handle)--csvExport :: (QA a) => FilePath -> [a] -> IO ()-csvExport file as = IO.withFile file IO.WriteMode (\handle -> csvExportHandle handle as)--csvExportStdout :: (QA a) => [a] -> IO ()-csvExportStdout = csvExportHandle IO.stdout--csvExportHandle :: (QA a) => Handle -> [a] -> IO ()-csvExportHandle handle as = T.hPutStr handle 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 _ _       -> "Nesting"-                    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]-+import Text.CSV -csvImport :: FilePath -> Type -> IO Norm+csvImport :: (Reify a) => FilePath -> Type [a] -> IO (Exp [a]) csvImport filepath csvType = do   let rType = recordType csvType   contents <- readFile filepath   let csv1 = case parseCSV filepath contents of                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))+  return (ListE (fmap (csvRecordToNorm rType) csv1))   where csvError :: String -> a         csvError s = error ("Error in '" ++ filepath ++ "': " ++ s) -        recordType :: Type -> Type+        recordType :: Type [a] -> Type a         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 a -> [String] -> Exp a+        csvRecordToNorm UnitT  [] = UnitE+        csvRecordToNorm t      [] = csvError ("When converting record '" ++ "[]" ++ "' to a value of type '" ++ show t ++ "'")+        csvRecordToNorm t1     [bs] = csvFieldToNorm t1 bs+        csvRecordToNorm (PairT (t1 :: Type b) (t2 :: Type c)) (bs : bss) = PairE (csvFieldToNorm t1 bs :: Exp b) (csvRecordToNorm t2 bss)+        csvRecordToNorm t           rs       = csvError ("When converting record '" ++ show rs ++ "' to a value of type '" ++ show t ++ "'") -        csvFieldToNorm :: Type -> String -> Norm++        csvFieldToNorm :: Type a -> String -> Exp a         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+          UnitT      -> UnitE+          BoolT      -> BoolE    (read s) +          CharT      -> CharE    (head s) +          IntegerT   -> IntegerE (read s) +          DoubleT    -> DoubleE  (read s) +          TextT      -> TextE    (T.pack s) +          _          -> er           where er = csvError ("When converting CSV field'" ++ s ++ "' to a value of type '" ++ show t ++ "'")

@@ -1,398 +0,0 @@-{-# 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 60)-$(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---}

@@ -1,15 +1,16 @@-{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, ParallelListComp #-} module Database.DSH.Compile where -import Database.DSH.Data-import Database.DSH.Impossible (impossible)+import Database.DSH.Internals+import Database.DSH.Impossible  import Database.Pathfinder  import qualified Data.Array as A import qualified Data.List as L-import Data.Maybe (fromJust, isNothing, isJust)+import Data.Maybe (fromJust, isNothing, isJust, fromMaybe) import Data.List (sortBy)+import Data.Function+import Control.Arrow import Control.Monad.Reader import Control.Exception (evaluate) @@ -17,7 +18,8 @@ import Text.XML.HaXml (Content(..), AttValue(..), tag, deep, children, xmlParse, Document(..))  import Database.HDBC-import Data.Convertible+import qualified Data.Text as T+import qualified Data.Text.Encoding as T  -- | Wrapper type with phantom type for algebraic plan -- The type variable represents the type of the result of the plan@@ -48,7 +50,7 @@ -- | Translate the algebraic plan to SQL and then execute it using the provided  -- DB connection. If debug is switchd on the SQL code is written to a file  -- named query.sql-executePlan :: forall a. forall conn. (QA a, IConnection conn) => conn -> AlgebraXML a -> IO Norm+executePlan :: forall a. forall conn. (Reify a, IConnection conn) => conn -> AlgebraXML a -> IO (Exp a) executePlan c p = do                         sql@(SQL _s) <- algToSQL p                         runSQL c $ extractSQL sql@@ -75,28 +77,26 @@ extractSQL (SQL q) = let (Document _ _ r _) = xmlParse "query" q                       in Bundle $ map extractQuery $ (deep $ tag "query_plan") (CElem r $impossible)     where-        extractQuery c@(CElem (X.Elem n attrs cs) _) = let qId = case fmap attrToInt $ lookup (X.N "id") attrs of-                                                                    Just x -> x-                                                                    Nothing -> $impossible+        extractQuery c@(CElem (X.Elem n attrs cs) _) = let qId = maybe ($impossible) attrToInt (lookup (X.N "id") attrs)                                                            rId = fmap attrToInt $ lookup (X.N "idref") attrs                                                            cId = fmap attrToInt $ lookup (X.N "colref") attrs                                                            ref = liftM2 (,) rId cId                                                            query = extractCData $  head $ concatMap children $ deep (tag "query") c-                                                           schema = toSchemeInf $ map process $ concatMap (\x -> deep (tag "column") x) $ deep (tag "schema") c+                                                           schema = toSchemeInf $ map process $ concatMap (deep (tag "column")) $ deep (tag "schema") c                                                         in (qId, (query, schema, ref))         extractQuery _ = $impossible         attrToInt :: AttValue -> Int-        attrToInt (AttValue [(Left i)]) = read i+        attrToInt (AttValue [Left i]) = read i         attrToInt _ = $impossible         attrToString :: AttValue -> String-        attrToString (AttValue [(Left i)]) = i+        attrToString (AttValue [Left i]) = i         attrToString _ = $impossible         extractCData :: Content i -> String         extractCData (CString _ d _) = d         extractCData _ = $impossible         toSchemeInf :: [(String, Maybe Int)] -> SchemaInfo         toSchemeInf results = let iterName = fst $ head $ filter (\(_, p) -> isNothing p) results-                                  cols = map (\(n, v) -> (n, fromJust v)) $ filter (\(_, p) -> isJust p) results+                                  cols = map (second fromJust) $ filter (\(_, p) -> isJust p) results                                in SchemaInfo iterName cols         process :: Content i -> (String, Maybe Int)         process (CElem (X.Elem _ attrs _) _) = let name = fromJust $ fmap attrToString $ lookup (X.N "name") attrs@@ -105,15 +105,15 @@         process _ = $impossible  -- | Execute the given SQL queries and assemble the results into one structure-runSQL :: forall a. forall conn. (QA a, IConnection conn) => conn -> QueryBundle a -> IO Norm+runSQL :: forall a. forall conn. (Reify a, IConnection conn) => conn -> QueryBundle a -> IO (Exp a) runSQL c (Bundle queries) = do                              results <- mapM (runQuery c) queries                              let (queryMap, valueMap) = foldr buildRefMap ([],[]) results                              let ty = reify (undefined :: a)                              let results' = runReader (processResults 0 ty) (queryMap, valueMap)-                             return $ case lookup 1 results' of-                                         Just x -> x -                                         Nothing -> ListN [] ty+                             case ty of+                                 (ListT _) -> return $ fromMaybe (ListE []) (lookup 1 results')+                                 _         -> return $ fromJust (lookup 1 results')  -- | Type of the environment under which we reconstruct ordinary haskell data from the query result. -- The first component of the reader monad contains a mapping from (queryNumber, columnNumber) to @@ -141,49 +141,86 @@ findQuery :: (Int, Int) -> QueryR Int findQuery (q, c) = do                     env <- ask-                    return $ (\x -> case x of-                                  Just x' -> x'-                                  Nothing -> error $ show $ fst env) $ lookup (q, c + 1) $ fst env+                    return $ fromMaybe (error $ show $ fst env) $ lookup (q, c + 1) $ fst env  -- | Reconstruct the haskell value out of the result of query i with type ty.-processResults :: Int -> Type -> QueryR [(Int, Norm)]-processResults i ty@(ListT t1) = do+processResults :: Int -> Type a -> QueryR [(Int, Exp a)]+processResults i (ListT t1) = do                                 v <- getResults i                                 mapM (\(it, vals) -> do                                                         v1 <- processResults' i 0 vals t1-                                                        return (it, ListN v1 ty)) v+                                                        return (it, ListE v1)) v processResults i t = do                         v <- getResults i                         mapM (\(it, vals) -> do                                               v1 <- processResults' i 0 vals t                                               return (it, head v1)) v +nrColsInType :: Type a -> Int+nrColsInType UnitT = 1+nrColsInType BoolT = 1+nrColsInType CharT = 1+nrColsInType IntegerT = 1+nrColsInType DoubleT = 1+nrColsInType TextT = 1+nrColsInType (PairT t1 t2) = nrColsInType t1 + nrColsInType t2+nrColsInType (ListT _) = 1+nrColsInType (ArrowT _ _) = $impossible+ -- | Reconstruct the values for column c of query q out of the rawData vals with type t.-processResults' :: Int -> Int -> [[SqlValue]] -> Type -> QueryR [Norm]-processResults' _ _ vals UnitT = return $ map (\_ -> UnitN UnitT) vals-processResults' q c vals t@(TupleT t1 t2) = do+processResults' :: Int -> Int -> [[SqlValue]] -> Type a -> QueryR [Exp a]+processResults' _ _ vals UnitT = return $ map (\_ -> UnitE) vals+processResults' q c vals (PairT t1 t2) = do                                             v1s <- processResults' q c vals t1-                                            v2s <- processResults' q (c + 1) vals t2-                                            return $ [TupleN v1 v2 t | v1 <- v1s | v2 <- v2s]+                                            v2s <- processResults' q (c + nrColsInType t1) vals t2+                                            return (zipWith PairE v1s v2s) 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 (maxV, vals') = foldr (\v (m,vs) -> let v' = sqlValueToInt (v !! i)+                                                                                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 `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' _ _ _ (ArrowT _ _) = $impossible -- The result cannot be a function+                                                    else fst $ L.maximumBy (compare `on` fst) list+                                        let lA = A.accumArray ($impossible) Nothing (1,maxI `max` maxV) [] A.// map (second Just) list+                                        return $ map (\val -> fromMaybe (ListE []) (lA A.! val)) vals'+processResults' _ _ _ (ArrowT _ _) = $impossible processResults' q c vals t = do                                     i <- getColResPos q c-                                    return $ map (\val -> convert $ (val !! i, t)) vals+                                    return $ map (\val -> convert (val !! i) t) vals +sqlValueToInt :: SqlValue -> Int+sqlValueToInt (SqlInteger i) = fromIntegral i+sqlValueToInt _ = $impossible +convert :: SqlValue -> Type a -> Exp a+convert SqlNull         UnitT    = UnitE+convert (SqlInteger i)  IntegerT = IntegerE i+convert (SqlInt32 i)    IntegerT = IntegerE $ fromIntegral i+convert (SqlInt64 i)    IntegerT = IntegerE $ fromIntegral i+convert (SqlWord32 i)   IntegerT = IntegerE $ fromIntegral i+convert (SqlWord64 i)   IntegerT = IntegerE $ fromIntegral i+convert (SqlDouble d)  DoubleT  = DoubleE d+convert (SqlRational d) DoubleT = DoubleE $ fromRational d+convert (SqlInteger d)  DoubleT = DoubleE $ fromIntegral d+convert (SqlInt32 d)    DoubleT = DoubleE $ fromIntegral d+convert (SqlInt64 d)    DoubleT = DoubleE $ fromIntegral d+convert (SqlWord32 d)   DoubleT = DoubleE $ fromIntegral d+convert (SqlWord64 d)   DoubleT = DoubleE $ fromIntegral d+convert (SqlBool b) BoolT       = BoolE b+convert (SqlInteger i) BoolT    = BoolE (i /= 0)+convert (SqlInt32 i)   BoolT    = BoolE (i /= 0)+convert (SqlInt64 i)   BoolT    = BoolE (i /= 0)+convert (SqlWord32 i)  BoolT    = BoolE (i /= 0)+convert (SqlWord64 i)  BoolT    = BoolE (i /= 0) +convert (SqlChar c) CharT       = CharE c+convert (SqlString (c:_)) CharT = CharE c+convert (SqlByteString c) CharT = CharE (head $ T.unpack $ T.decodeUtf8 c)+convert (SqlString t) TextT     = TextE (T.pack t) +convert (SqlByteString s) TextT = TextE (T.decodeUtf8 s)+convert sql                 _   = error $ "Unsupported SqlValue: "  ++ show sql+ -- | Partition by iter column -- The first argument is the position of the iter column. -- The second argument the raw data@@ -194,7 +231,7 @@                        in (i, v:vi) : partByIter n vr        where            getIter :: Int -> [SqlValue] -> Int-           getIter n' vals = ((fromSql (vals !! n'))::Int)+           getIter n' vals = fromSql (vals !! n') :: Int partByIter _ [] = []  @@ -224,11 +261,11 @@ -- | Transform algebraic plan scheme info into resultinfo schemeToResult :: SchemaInfo -> [(String, SqlColDesc)] -> ResultInfo schemeToResult (SchemaInfo itN cols) resDescr = let ordCols = sortBy (\(_, c1) (_, c2) -> compare c1 c2) cols-                                                    resColumns = flip zip [0..] $ map (\(c, _) -> takeWhile (\a -> a /= '_') c) resDescr+                                                    resColumns = flip zip [0..] $ map (\(c, _) -> takeWhile (/= '_') c) resDescr                                                     itC = fromJust $ lookup itN resColumns                                                  in ResultInfo itC $ map (\(n, _) -> (n, fromJust $ lookup n resColumns)) ordCols  -- |  buildRefMap :: (Int, ([(Int, [[SqlValue]])], ResultInfo, Maybe (Int, Int))) -> ([((Int, Int), Int)] ,[(Int, ([(Int, [[SqlValue]])], ResultInfo))]) -> ([((Int, Int), Int)] ,[(Int, ([(Int, [[SqlValue]])], ResultInfo))])-buildRefMap (q, (r, ri, (Just (t, c)))) (qm, rm) = (((t, c), q):qm, (q, (r, ri)):rm)+buildRefMap (q, (r, ri, Just (t, c))) (qm, rm) = (((t, c), q):qm, (q, (r, ri)):rm) buildRefMap (q, (r, ri, _)) (qm, rm) = (qm, (q, (r, ri)):rm)

@@ -3,13 +3,11 @@ -- FerryCore which is then translated into SQL (through a table algebra). The SQL -- code is executed on the database and then processed to form a Haskell value. -{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, ScopedTypeVariables #-}--module Database.DSH.Compiler (fromQ, debugPlan, debugCore, debugPlanOpt, debugSQL) where+module Database.DSH.Compiler (fromQ, debugPlan, debugCore, debugPlanOpt, debugSQL, debugCoreDot) where -import Database.DSH.Data as D-import Database.DSH.Impossible (impossible)-import Database.DSH.CSV (csvImport)+import Database.DSH.Internals as D+import Database.DSH.Impossible+import Database.DSH.CSV  import Database.DSH.Compile as C @@ -19,7 +17,6 @@ import qualified Data.Map as M import Data.Char import Database.HDBC-import Data.Convertible  import Control.Monad.State import Control.Applicative@@ -29,12 +26,10 @@ import Data.List (nub) import qualified Data.List as L -import Data.Generics (listify)- {- N monad, version of the state monad that can provide fresh variable names. -}-type N conn = StateT (conn, Int, M.Map String [(String, (FType -> Bool))]) IO+type N conn = StateT (conn, Int, M.Map String [(String,FType -> Bool)]) IO  -- | Provide a fresh identifier name during compilation freshVar :: N conn Int@@ -52,7 +47,7 @@ -- | Lookup information that describes a table. If the information is  -- not present in the state then the connection is used to retrieve the -- table information from the Database.-tableInfo :: IConnection conn => String -> N conn [(String, (FType -> Bool))]+tableInfo :: IConnection conn => String -> N conn [(String,FType -> Bool)] tableInfo t = do                (c, i, env) <- get                case M.lookup t env of@@ -64,7 +59,7 @@  -- | Turn a given integer into a variable beginning with prefix "__fv_"                     prefixVar :: Int -> String-prefixVar = ((++) "__fv_") . show+prefixVar = (++) "__fv_" . show       -- | Execute the transformation computation. During -- compilation table information can be retrieved from@@ -77,157 +72,167 @@  -- | Execute the query on the database fromQ :: (QA a, IConnection conn) => conn -> Q a -> IO a-fromQ c a = evaluate c a >>= (return . fromNorm)-+fromQ c (Q e) = fmap frExp (evaluate c e)  -- | Convert the query into unoptimised algebraic plan-debugPlan :: (QA a, IConnection conn) => conn -> Q a -> IO String+debugPlan :: (IConnection conn,Reify a) => conn -> Exp a -> IO String debugPlan = doCompile  -- | Convert the query into optimised algebraic plan-debugPlanOpt :: (QA a, IConnection conn) => conn -> Q a -> IO String+debugPlanOpt :: (IConnection conn,Reify a) => conn -> Exp a -> IO String debugPlanOpt q c = do                     p <- doCompile q c-                    (C.Algebra r) <- algToAlg ((C.Algebra p)::AlgebraXML a)+                    (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+debugCore :: (IConnection conn,Reify a) => conn -> Exp a -> IO String+debugCore c a = do core <- runN c $ transformE a+                   return $ show core ++debugCoreDot :: (IConnection conn,Reify a) => conn -> Exp a -> IO String+debugCoreDot c a = do core <- runN c $ transformE a+                      return $ (\(Right d) -> d) $ dot core+ -- | Convert the query into SQL-debugSQL :: (QA a, IConnection conn) => conn -> Q a -> IO String-debugSQL q c = do-                p <- doCompile q c-                (C.SQL r) <- algToSQL ((C.Algebra p)::AlgebraXML a)-                return r+debugSQL :: (IConnection conn,Reify a) => conn -> Exp a -> IO String+debugSQL q c = do p <- doCompile q c+                  (C.SQL r) <- algToSQL (C.Algebra p :: AlgebraXML a)+                  return r  -- | evaluate compiles the given Q query into an executable plan, executes this and returns  -- the result as norm. For execution it uses the given connection. If the boolean flag is set -- to true it outputs the intermediate algebraic plan to disk.-evaluate :: forall a. forall conn. (QA a, IConnection conn)-         =>  conn-         -> Q a-         -> IO Norm-evaluate c q = do-                  algPlan' <- doCompile c q-                  let algPlan = ((C.Algebra algPlan') :: AlgebraXML a)+evaluate :: (Reify a, IConnection conn) => conn -> Exp a -> IO (Exp a)+evaluate c q = do algPlan' <- doCompile c q+                  let algPlan = C.Algebra algPlan' :: AlgebraXML a                   n <- executePlan c algPlan                   disconnect c                   return n  -- | Transform a query into an algebraic plan.                   -doCompile :: IConnection conn => conn -> Q a -> IO String-doCompile c (Q a) = do -                        core <- runN c $ transformE a-                        return $ typedCoreToAlgebra core+doCompile :: (IConnection conn, Reify a) => conn -> Exp a -> IO String+doCompile c a = do core <- runN c $ transformE a+                   return $ typedCoreToAlgebra core  -- | Transform the Query into a ferry core program.-transformE :: IConnection conn => Exp -> N conn CoreExpr-transformE (UnitE _) = return $ Constant ([] :=> int) $ CInt 1-transformE (BoolE b _) = return $ Constant ([] :=> bool) $ CBool b-transformE (CharE c _) = return $ Constant ([] :=> string) $ CString [c] -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 (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 (AppE1 f1 e1 ty) = do-                                      let tr = transformTy ty-                                      e1' <- transformArg e1-                                      let (_ :=> ta) = typeOf e1'-                                      return $ App ([] :=> tr) (transformF f1 (ta .-> tr)) e1'--- transformE ((AppE2 GroupWith fn e) ::: ty) = transformE $ ListE [e] ::: ty-transformE (AppE2 Span f e t@(TupleT t1 t2)) = transformE $ TupleE (AppE2 TakeWhile f e t1) (AppE2 DropWhile f e t2) t-transformE (AppE2 Break (LamE f _) e t@(TupleT t1 _)) = let notF = LamE (\x -> AppE1 Not (f x) BoolT) $ ArrowT t1 BoolT-                                                 in transformE $ AppE2 Span notF e t-transformE (AppE2 GroupWith gfn e ty@(ListT (ListT tel))) = do-                                                let tr = transformTy ty-                                                fn' <- transformArg 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 <- transformArg (LamE id $ ArrowT tel tel)-                                                snd' <- transformArg (LamE (\x -> AppE1 Snd x $ ArrowT (TupleT (transformTy' rt) (ListT tel)) (ListT tel)) $ ArrowT (TupleT (transformTy' rt) (ListT tel)) (ListT tel))-                                                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')-transformE (AppE2 D.Cons e1 e2 _) = do+transformE :: forall a conn. (IConnection conn, Reify a) => Exp a -> N conn CoreExpr+transformE (UnitE ) = return $ Constant ([] :=> int) $ CInt 1+transformE (BoolE b) = return $ Constant ([] :=> bool) $ CBool b+transformE (CharE c) = return $ Constant ([] :=> string) $ CString [c] +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 (PairE e1 e2) = do let ty = reify (undefined :: a)+                              c1 <- transformE e1+                              c2 <- transformE e2+                              return $ Rec ([] :=> transformTy ty) [RecElem (typeOf c1) "1" c1, RecElem (typeOf c2) "2" c2] +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)+  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')+transformE (AppE D.Cons (PairE e1 e2)) = do                                             e1' <- transformE e1                                             e2' <- transformE e2                                             let (_ :=> t) = typeOf e1'                                             return $ F.Cons ([] :=> list t) e1' e2'-transformE (AppE2 Append e1 e2 t) = transformE (AppE1 Concat (ListE [e1, e2] (ListT t)) t)-transformE (AppE2 Any f e _) = transformE $ AppE1 Or (AppE2 Map f e $ ListT BoolT) BoolT-transformE (AppE2 All f e _) = transformE $ AppE1 And (AppE2 Map f e $ ListT BoolT) BoolT-transformE (AppE2 Snoc e1 e2 t) = transformE (AppE2 Append e1 (ListE [e2] t) t)-transformE (AppE2 f2 e1 e2 ty) = do-                                        let tr = transformTy ty-                                        case elem f2 [Add, Sub, Mul, Div, Equ, Lt, Lte, Gte, Gt, Conj, Disj] of-                                            True  -> do-                                                      e1' <- transformE e1-                                                      e2' <- transformE e2-                                                      return $ BinOp ([] :=> tr) (transformOp f2) e1' e2'-                                            False -> do-                                                      e1' <- transformArg e1-                                                      e2' <- transformArg e2-                                                      let (_ :=> ta1) = typeOf e1'-                                                      let (_ :=> ta2) = typeOf e2'-                                                      return $ App ([] :=> tr) -                                                                (App ([] :=> ta2 .-> tr) (transformF f2 (ta1 .-> ta2 .-> tr)) e1')-                                                                e2'-transformE (AppE3 Cond e1 e2 e3 _) = do+transformE (AppE Cond (PairE e1 (PairE e2 e3))) = do                                              e1' <- transformE e1                                              e2' <- transformE e2                                              e3' <- transformE e3                                              let (_ :=> t) = typeOf e2'                                              return $ If ([] :=> t) e1' e2' e3'-transformE (AppE3 f3 e1 e2 e3 ty) = do-                                           let tr = transformTy ty-                                           e1' <- transformArg e1-                                           e2' <- transformArg e2-                                           e3' <- transformArg e3-                                           let (_ :=> ta1) = typeOf e1'-                                           let (_ :=> ta2) = typeOf e2'-                                           let (_ :=> ta3) = typeOf e3'-                                           return $ App ([] :=> tr)-                                                        (App ([] :=> ta3 .-> tr)-                                                             (App ([] :=> ta2 .-> ta3 .-> tr) (transformF f3 (ta1 .-> ta2 .-> ta3 .-> tr)) e1')-                                                             e2')-                                                        e3'-transformE (VarE i ty) = return $ Var ([] :=> transformTy ty) $ prefixVar i-transformE (TableE (TableCSV filepath) ty) = do-                                              norm1 <- lift (csvImport filepath ty)-                                              transformE (convert norm1)+transformE (AppE Fst (PairE e1 e2)) = do+  let ty = reify (undefined :: a)+  let tr = transformTy ty+  e1' <- transformArg (PairE e1 e2)+  let (_ :=> ta) = typeOf e1'+  return $ App ([] :=> tr) (transformF Fst (ta .-> tr)) e1'++transformE (AppE Snd (PairE e1 e2)) = do+  let ty = reify (undefined :: a)+  let tr = transformTy ty+  e1' <- transformArg (PairE e1 e2)+  let (_ :=> ta) = typeOf e1'+  return $ App ([] :=> tr) (transformF Snd (ta .-> tr)) e1'++transformE (AppE f2 (PairE (LamE f) e)) = do+  let ty = reify (undefined :: a)+  let tr = transformTy ty+  f' <- transformLamArg (LamE f)+  e' <- transformArg e+  let (_ :=> t1) = typeOf f'+  let (_ :=> t2) = typeOf e'+  return $ App ([] :=> tr)+              (App ([] :=> t2 .-> tr) (transformF f2 (t1 .-> t2 .-> tr)) f')+              e'++transformE (AppE f2 (PairE e1 e2)) = do+  let ty = reify (undefined :: a)+  let tr = transformTy ty+  if isOp f2+     then do e1' <- transformE e1+             e2' <- transformE e2+             return $ BinOp ([] :=> tr) (transformOp f2) e1' e2'+     else do e1' <- transformArg e1+             e2' <- transformArg e2+             let (_ :=> ta1) = typeOf e1'+             let (_ :=> ta2) = typeOf e2'+             return $ App ([] :=> tr) (App ([] :=> ta2 .-> tr) (transformF f2 (ta1 .-> ta2 .-> tr)) e1') e2'++transformE (AppE f1 e1) = do+  let ty = reify (undefined :: a)+  let tr = transformTy ty+  e1' <- transformArg e1+  let (_ :=> ta) = typeOf e1'+  return $ App ([] :=> tr) (transformF f1 (ta .-> tr)) e1'++transformE (VarE i) = do+  let ty = reify (undefined :: a)+  return $ Var ([] :=> transformTy ty) $ prefixVar $ fromIntegral i+  +transformE (TableE (TableCSV filepath)) = do+  let ty = reify (undefined :: a)+  e1 <- lift (csvImport filepath ty)+  transformE e1+ -- When a table node is encountered check that the given description -- matches the actual table information in the database.-transformE (TableE (TableDB n ks) ty) = do+transformE (TableE (TableDB n ks)) = do+                                    let ty = reify (undefined :: a)                                     fv <- freshVar                                     let tTy@(FList (FRec ts)) = flatFTy ty                                     let varB = Var ([] :=> FRec ts) $ prefixVar fv                                     tableDescr <- tableInfo n-                                    let tyDescr = case length tableDescr == length ts of-                                                    True -> zip tableDescr ts-                                                    False -> error $ "Inferred typed: " ++ show tTy ++ " \n doesn't match type of table: \"" -                                                                        ++ n ++ "\" in the database. The table has the shape: " ++ (show $ map fst tableDescr) ++ ". " ++ show ty +                                    let tyDescr = if length tableDescr == length ts+                                                    then zip tableDescr ts+                                                    else error $ "Inferred typed: " ++ show tTy ++ " \n doesn't match type of table: \"" +                                                                        ++ n ++ "\" in the database. The table has the shape: " ++ show (map fst tableDescr) ++ ". " ++ show ty                                      let cols = [Column cn t | ((cn, f), (RLabel i, t)) <- tyDescr, legalType n cn i t f]-                                    let keyCols = (nub $ concat ks) L.\\ (map fst tableDescr)-                                    let keys = if (keyCols == [])-                                                    then if (ks /= []) then map Key ks else [Key $ map (\(Column n' _) -> n') cols]-                                                    else error $ "The following columns were used as key but not a column of table " ++ n ++ " : " ++ show keyCols+                                    let keyCols = nub (concat ks) L.\\ map fst tableDescr+                                    let keys = if keyCols == []+                                                  then if ks /= [] then map Key ks else [Key $ map (\(Column n' _) -> n') cols]+                                                  else error $ "The following columns were used as key but not a column of table " ++ n ++ " : " ++ show keyCols                                     let table' = Table ([] :=> tTy) n cols keys                                     let pattern = [prefixVar fv]                                     let nameType = map (\(Column name t) -> (name, t)) cols @@ -245,81 +250,85 @@                                     return expr     where         legalType :: String -> String -> String -> FType -> (FType -> Bool) -> Bool-        legalType tn cn nr t f = case f t of-                                True -> True-                                False -> error $ "The type: " ++ show t ++ "\nis not compatible with the type of column nr: " ++ nr-                                                    ++ " namely: " ++ cn ++ "\n in table " ++ tn ++ "."-transformE (LamE _ _) = $impossible+        legalType tn cn nr t f = f t || error ( "The type: "+                                                ++ show t+                                                ++ "\nis not compatible with the type of column nr: " ++ nr+                                                ++ " namely: " ++ cn ++ "\n in table " ++ tn ++ ".")+transformE (LamE _) = $impossible --- | Transform a function argument-transformArg :: IConnection conn => Exp -> N conn Param                                 -transformArg (LamE f ty) = do-                                  n <- freshVar-                                  let (ArrowT t1 _) = ty-                                  let fty = transformTy ty-                                  let e1 = f $ VarE n t1-                                  case e1 of-                                    l@(LamE _ _) -> do-                                                     (ParAbstr _ vs e') <- transformArg l-                                                     return $ ParAbstr ([] :=> fty) ((prefixVar n):vs) e'-                                    _           -> ParAbstr ([] :=> fty) [prefixVar n] <$> transformE e1-transformArg e = (\e' -> ParExpr (typeOf e') e') <$> transformE e +transformLamArg :: forall a b conn. (IConnection conn) => Exp (a -> b) -> N conn Param+transformLamArg (LamE f) = do +  let ty = reify (undefined :: a -> b)+  n <- freshVar+  let fty = transformTy ty+  let e1 = f $ VarE $ fromIntegral n +  ParAbstr ([] :=> fty) [prefixVar n] <$> transformE e1+transformLamArg (AppE _ _) = $impossible+transformLamArg (VarE _)   = $impossible ++transformArg :: (IConnection conn,Reify a) => Exp a -> N conn Param+transformArg e = (\e' -> ParExpr (typeOf e') e') <$> transformE e+  -- | Construct a flat-FerryCore type out of a DSH type -- A flat type consists out of two tuples, a record is translated as: -- {r1 :: t1, r2 :: t2, r3 :: t3, r4 :: t4} (t1, (t2, (t3, t4)))-flatFTy :: Type -> FType+flatFTy :: Type a -> FType flatFTy (ListT t) = FList $ FRec $ flatFTy' 1 t  where-     flatFTy' :: Int -> Type -> [(RLabel, FType)]-     flatFTy' i (TupleT t1 t2) = (RLabel $ show i, transformTy t1) : (flatFTy' (i + 1) t2)-     flatFTy' i ty              = [(RLabel $ show i, transformTy ty)]+     flatFTy' :: Int -> Type a -> [(RLabel, FType)]+     flatFTy' i (PairT t1 t2) = (RLabel $ show i, transformTy t1) : flatFTy' (i + 1) t2+     flatFTy' i ty            = [(RLabel $ show i, transformTy ty)] flatFTy _         = $impossible  -- Determine the size of a flat type-sizeOfTy :: Type -> Int-sizeOfTy (TupleT _ t2) = 1 + sizeOfTy t2+sizeOfTy :: Type a -> Int+sizeOfTy (PairT _ t2) = 1 + sizeOfTy t2 sizeOfTy _              = 1   -- | Transform an arbitrary DSH-type into a ferry core type -transformTy :: Type -> FType+transformTy :: Type a -> FType transformTy UnitT = int transformTy BoolT = bool transformTy CharT = string transformTy TextT = string transformTy IntegerT = int transformTy DoubleT = float-transformTy (TupleT t1 t2) = FRec [(RLabel "1", transformTy t1), (RLabel "2", transformTy t2)]+transformTy (PairT 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)+transformTy (ArrowT t1 t2) = transformTy t1 .-> transformTy t2 --- | Transform a ferry-core type into a DSH-type-transformTy' :: FType -> Type-transformTy' FUnit = UnitT-transformTy' FInt  = IntegerT-transformTy' FFloat = DoubleT-transformTy' FString = TextT-transformTy' FBool = BoolT-transformTy' (FList t) = ListT $ transformTy' t-transformTy' (FRec [(RLabel "1", t1), (RLabel "2", t2)]) = TupleT (transformTy' t1) (transformTy' t2)-transformTy' (FFn t1 t2) = ArrowT (transformTy' t1) (transformTy' t2)-transformTy' _ = $impossible +isOp :: Fun a b -> Bool+isOp Add  = True+isOp Sub  = True+isOp Mul  = True+isOp Div  = True+isOp Equ  = True+isOp Lt   = True+isOp Lte  = True+isOp Gte  = True+isOp Gt   = True+isOp Conj = True+isOp Disj = True+isOp _    = False+ -- | Translate the DSH operator to Ferry Core operators-transformOp :: Fun2 -> Op-transformOp Add = Op "+"-transformOp Sub = Op "-"-transformOp Mul = Op "*"-transformOp Div = Op "/"-transformOp Equ = Op "=="-transformOp Lt = Op "<"-transformOp Lte = Op "<="-transformOp Gte = Op ">="-transformOp Gt = Op ">"+transformOp :: Fun a b -> Op+transformOp Add  = Op "+"+transformOp Sub  = Op "-"+transformOp Mul  = Op "*"+transformOp Div  = Op "/"+transformOp Equ  = Op "=="+transformOp Lt   = Op "<"+transformOp Lte  = Op "<="+transformOp Gte  = Op ">="+transformOp Gt   = Op ">" transformOp Conj = Op "&&" transformOp Disj = Op "||"-transformOp _ = $impossible+transformOp _    = $impossible + -- | Transform a DSH-primitive-function (f) with an instantiated typed into a FerryCore -- expression transformF :: (Show f) => f -> FType -> CoreExpr@@ -327,32 +336,21 @@                                             (x:xs) -> toLower x : xs                                             _      -> $impossible) $ show f --- | Retrieve all DB-table names from a DSH program-getTableNames :: Exp -> [String]-getTableNames e = let tables = map (\t -> case t of-                                        (TableE (TableDB n _) _) -> n-                                        _                        -> $impossible) $ listify isTable e-                   in nub tables-    where -        isTable :: Exp -> Bool-        isTable (TableE (TableDB _ _) _) = True-        isTable _                        = False- -- | Retrieve through the given database connection information on the table (columns with their types) -- which name is given as the second argument.        -getTableInfo :: IConnection conn => conn -> String -> IO [(String, (FType -> Bool))]+getTableInfo :: IConnection conn => conn -> String -> IO [(String,FType -> Bool)] getTableInfo c n = do                     info <- describeTable c n                     return $ toTableDescr info                              where-          toTableDescr :: [(String, SqlColDesc)] -> [(String, (FType -> Bool))]+          toTableDescr :: [(String, SqlColDesc)] -> [(String,FType -> Bool)]           toTableDescr = L.sortBy (\(n1, _) (n2, _) -> compare n1 n2) . map (\(name, props) -> (name, compatibleType (colType props)))           compatibleType :: SqlTypeId -> FType -> Bool           compatibleType dbT hsT = case hsT of-                                        FUnit -> True-                                        FBool -> L.elem dbT [SqlSmallIntT, SqlIntegerT, SqlBitT]-                                        FString -> L.elem dbT [SqlCharT, SqlWCharT, SqlVarCharT]-                                        FInt -> L.elem dbT [SqlSmallIntT, SqlIntegerT, SqlTinyIntT, SqlBigIntT, SqlNumericT]-                                        FFloat -> L.elem dbT [SqlDecimalT, SqlRealT, SqlFloatT, SqlDoubleT]+                                        FUnit   -> True+                                        FBool   -> dbT `L.elem` [SqlSmallIntT, SqlIntegerT, SqlBitT]+                                        FString -> dbT `L.elem` [SqlCharT, SqlWCharT, SqlVarCharT]+                                        FInt    -> dbT `L.elem` [SqlSmallIntT, SqlIntegerT, SqlTinyIntT, SqlBigIntT, SqlNumericT]+                                        FFloat  -> dbT `L.elem` [SqlDecimalT, SqlRealT, SqlFloatT, SqlDoubleT]                                         t       -> error $ "You can't store this kind of data in a table... " ++ show t ++ " " ++ show n

@@ -1,463 +0,0 @@-{-# LANGUAGE TemplateHaskell, ViewPatterns, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, DeriveDataTypeable #-}--module Database.DSH.Data where--import Database.DSH.Impossible--import Data.Convertible-import Data.Typeable-import Database.HDBC-import Data.Generics-import Data.Text(Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T--import GHC.Exts--data Exp =-    UnitE Type-  | BoolE Bool Type-  | CharE Char Type-  | IntegerE Integer Type-  | DoubleE Double Type-  | TextE Text Type-  | TupleE Exp Exp Type-  | ListE [Exp] Type-  | LamE (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 (Show, Data, Typeable)--instance Show (Exp -> Exp) where-  show _ = "(f :: Exp -> Exp)"--data Fun1 =-    Fst | Snd | Not | IntegerToDouble-  | Head | Tail | Unzip | Minimum-  | Maximum | Concat | Sum | And-  | Or | Reverse | Length | Null | Init-  | Last | The | Nub-  deriving (Eq, Ord, Show, Data, Typeable)---data Fun2 =-    Add | Mul | Sub | Div | All | Any | Index-  | SortWith | Cons | Snoc | Take | Drop-  | Map | Append | Filter | GroupWith | Zip-  | Break | Span | DropWhile | TakeWhile-  | SplitAt | Equ | Conj | Disj-  | Lt | Lte | Gte | Gt | Max | Min-  deriving (Eq, Ord, Show, Data, Typeable)--data Fun3 = Cond | ZipWith-  deriving (Eq, Ord, Show, Data, Typeable)---data Norm =-    UnitN Type-  | BoolN Bool Type-  | CharN Char Type-  | IntegerN Integer Type-  | DoubleN Double Type-  | TextN Text Type-  | TupleN Norm Norm Type-  | ListN [Norm] Type-  deriving (Eq, Ord, Show, Data, Typeable)--data Type =-    UnitT-  | BoolT-  | CharT-  | IntegerT-  | DoubleT-  | TextT-  | TupleT Type Type-  | ListT Type-  | ArrowT Type Type-  deriving (Eq, Ord, Show, Data, Typeable)---data Table =-    TableDB   String [[String]]-  | TableCSV  String-  deriving (Eq, Ord, Show, Data, Typeable)---typeExp :: Exp -> Type-typeExp e = case e of-  UnitE t -> t-  BoolE _ t -> t-  CharE _ t -> t-  IntegerE _ t -> t-  DoubleE _ t -> t-  TextE _ t -> t-  TupleE _ _ t -> t-  ListE _ t -> t-  LamE _ t -> t-  AppE1 _ _ t -> t-  AppE2 _ _ _ t -> t-  AppE3 _ _ _ _ t -> t-  TableE _ t -> t-  VarE _ t -> t--typeArrowResult :: Type -> Type-typeArrowResult (ArrowT _ t) = t-typeArrowResult _ = $impossible--typeTupleFst :: Type -> Type-typeTupleFst (TupleT a _) = a-typeTupleFst _ = $impossible--typeTupleSnd :: Type -> Type-typeTupleSnd (TupleT _ b) = b-typeTupleSnd _ = $impossible--typeNorm :: Norm -> Type-typeNorm = typeExp . convert--data Q a = Q Exp deriving (Show, Data, Typeable)--class QA a where-  reify :: a -> Type-  toNorm :: a -> Norm-  fromNorm :: Norm -> a--instance QA () where-  reify _ = UnitT-  toNorm _ = UnitN UnitT-  fromNorm (UnitN UnitT) = ()-  fromNorm _ = $impossible--instance QA Bool where-  reify _ = BoolT-  toNorm b = BoolN b BoolT-  fromNorm (BoolN b BoolT) = b-  fromNorm v = $impossible--instance QA Char where-  reify _ = CharT-  toNorm c = CharN c CharT-  fromNorm (CharN c CharT) = c-  fromNorm _ = $impossible--instance QA Integer where-  reify _ = IntegerT-  toNorm i = IntegerN i IntegerT-  fromNorm (IntegerN i IntegerT) = i-  fromNorm _ = $impossible--instance QA Double where-  reify _ = DoubleT-  toNorm d = DoubleN d DoubleT-  fromNorm (DoubleN i DoubleT) = i-  fromNorm _ = $impossible--instance QA Text where-    reify _ = TextT-    toNorm t = TextN t TextT-    fromNorm (TextN t TextT) = 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))-  fromNorm (TupleN a b (TupleT _ _)) = (fromNorm a,fromNorm b)-  fromNorm _ = $impossible--instance (QA a) => QA [a] where-  reify _ = ListT (reify (undefined :: a))-  toNorm as = ListN (map toNorm as) (reify as)-  fromNorm (ListN as (ListT _)) = map fromNorm as-  fromNorm _ = $impossible--instance (QA a) => QA (Maybe a) where-  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-instance BasicType Bool where-instance BasicType Char where-instance BasicType Integer where-instance BasicType Double where-instance BasicType Text where---- * Refering to Real Database Tables--class (QA a) => TA a where-  tablePersistence :: Table -> Q [a]-  tablePersistence t = Q (TableE t (reify (undefined :: [a])))---table :: (TA a) => String -> Q [a]-table = tableDB--tableDB :: (TA a) => String -> Q [a]-tableDB name = tablePersistence (TableDB name [])--tableWithKeys :: (TA a) => String -> [[String]] -> Q [a]-tableWithKeys name keys = tablePersistence (TableDB name keys)--tableCSV :: (TA a) => String -> Q [a]-tableCSV filename = tablePersistence (TableCSV filename)---instance TA () where-instance TA Bool where-instance TA Char where-instance TA Integer where-instance TA Double where-instance TA Text where-instance (BasicType a, BasicType b, QA a, QA b) => TA (a,b) where---- * Eq, Ord and Num Instances for Databse Queries--instance Eq (Q Integer) where-  (==) _ _ = error "Eq instance for (Q Integer) must not be used."--instance Eq (Q Double) where-  (==) _ _ = error "Eq instance for (Q Double) must not be used."--instance Num (Q Integer) where-  (+) (Q e1) (Q e2) = Q (AppE2 Add e1 e2 IntegerT)-  (*) (Q e1) (Q e2) = Q (AppE2 Mul e1 e2 IntegerT)-  (-) (Q e1) (Q e2) = Q (AppE2 Sub e1 e2 IntegerT)--  fromInteger i = Q (IntegerE i      IntegerT)--  abs (Q e1) =-    let zero      = IntegerE 0 IntegerT-        e1Negated = AppE2 Sub zero e1 IntegerT-    in Q (AppE3 Cond (AppE2 Lt e1 zero BoolT) e1Negated e1 IntegerT)--  signum (Q e1) =-    let zero     = IntegerE 0 IntegerT-        one      = IntegerE 1 IntegerT-        minusOne = IntegerE (negate 1) IntegerT-    in Q (AppE3 Cond (AppE2 Lt e1 zero BoolT)-                     (minusOne)-                     (AppE3 Cond (AppE2 Equ e1 zero BoolT) zero one IntegerT)-                     IntegerT)--instance Num (Q Double) where-  (+) (Q e1) (Q e2) = Q (AppE2 Add e1 e2 DoubleT)-  (*) (Q e1) (Q e2) = Q (AppE2 Mul e1 e2 DoubleT)-  (-) (Q e1) (Q e2) = Q (AppE2 Sub e1 e2 DoubleT)--  fromInteger d     = Q (DoubleE (fromIntegral d) DoubleT)--  abs (Q e1) =-    let zero      = DoubleE 0.0 DoubleT-        e1Negated = AppE2 Sub zero e1 DoubleT-    in Q (AppE3 Cond (AppE2 Lt e1 zero BoolT) e1Negated e1 DoubleT)--  signum (Q e1) =-    let zero     = DoubleE 0.0 DoubleT-        one      = DoubleE 1.0 DoubleT-        minusOne = DoubleE (negate 1.0) DoubleT-    in Q (AppE3 Cond (AppE2 Lt e1 zero BoolT)-                     (minusOne)-                     (AppE3 Cond (AppE2 Equ e1 zero BoolT) zero one DoubleT)-                     DoubleT)---instance Fractional (Q Double) where-  (/) (Q e1) (Q e2) = Q (AppE2 Div e1 e2          DoubleT)-  fromRational r    = Q (DoubleE (fromRational r) DoubleT)---- * Support for View Patterns--class View a b | a -> b, b -> a where-  view :: a -> b-  fromView :: b -> a--tuple :: (View a b) => b -> a-tuple = fromView--record :: (View a b) => b -> a-record = fromView--instance View (Q ()) (Q ()) where-  view = id-  fromView = id--instance View (Q Bool) (Q Bool) where-  view = id-  fromView = id--instance View (Q Char) (Q Char) where-  view = id-  fromView = id--instance View (Q Integer) (Q Integer) where-  view = id-  fromView = id--instance View (Q Double) (Q Double) where-  view = id-  fromView = id--instance View (Q Text) (Q Text) 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))))--instance Convertible Norm Exp where-    safeConvert n = Right $-        case n of-             UnitN t        -> UnitE t-             BoolN b t      -> BoolE b t-             CharN c t      -> CharE c t-             TextN s t      -> TextE s t-             IntegerN i t   -> IntegerE i t-             DoubleN d t    -> DoubleE d t-             TupleN n1 n2 t -> TupleE (convert n1) (convert n2) t-             ListN ns t     -> ListE (map convert ns) t--forget :: (QA a) => Q a -> Exp-forget (Q a) = a--toLam1 :: forall a b. (QA a,QA b) => (Q a -> Q b) -> Exp-toLam1 f = LamE (forget . f . Q) (ArrowT (reify (undefined :: a)) (reify (undefined :: b)))--toLam2 :: forall a b c. (QA a,QA b,QA c) => (Q a -> Q b -> Q c) -> Exp-toLam2 f =-  let f1 = \a b -> forget (f (Q a) (Q b))-      t1 = ArrowT (reify (undefined :: b)) (reify (undefined :: c))-      f2 = \a -> LamE (\b -> f1 a b) t1-      t2 = ArrowT (reify (undefined :: a)) t1-  in  LamE f2 t2--unfoldType :: Type -> [Type]-unfoldType (TupleT t1 t2) = t1 : unfoldType t2-unfoldType t = [t]--instance Convertible Type SqlTypeId where-    safeConvert n =-        case n of-             IntegerT       -> Right SqlBigIntT-             DoubleT        -> Right SqlDoubleT-             BoolT          -> Right SqlBitT-             CharT          -> Right SqlCharT-             TextT          -> Right SqlVarCharT-             UnitT          -> convError "No `UnitT' representation" n-             TupleT {}      -> convError "No `TupleT' representation" n-             ListT {}       -> convError "No `ListT' representation" n-             ArrowT {}      -> convError "No `ArrowT' representation" n--instance Convertible SqlTypeId Type where-    safeConvert n =-        case n of-          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-    safeConvert sql =-        case sql of-             SqlNull            -> Right $ UnitN UnitT-             SqlInteger i       -> Right $ IntegerN i IntegerT-             SqlDouble d        -> Right $ DoubleN d DoubleT-             SqlBool b          -> Right $ BoolN b BoolT-             SqlChar c          -> Right $ CharN c CharT-             SqlString t        -> Right $ TextN (T.pack t) TextT-             SqlByteString s    -> Right $ TextN (T.decodeUtf8 s) TextT-             _                  -> convError "Unsupported `SqlValue'" sql--instance Convertible (SqlValue, Type) Norm where-    safeConvert sql =-        case sql of-          (SqlNull, UnitT)         -> Right $ UnitN UnitT--          (SqlInteger i, IntegerT) -> Right $ IntegerN i IntegerT-          (SqlInt32 i, IntegerT)   -> Right $ flip IntegerN IntegerT $ convert i-          (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-          (SqlInteger i, DoubleT)  -> Right $ flip DoubleN DoubleT $ convert i-          (SqlInt32 i, DoubleT)    -> Right $ flip DoubleN DoubleT $ convert i-          (SqlInt64 i, DoubleT)    -> Right $ flip DoubleN DoubleT $ convert i-          (SqlWord32 i, DoubleT)   -> Right $ flip DoubleN DoubleT $ convert i-          (SqlWord64 i, DoubleT)   -> Right $ flip DoubleN DoubleT $ convert i--          (SqlBool b, BoolT)       -> Right $ BoolN b BoolT-          (SqlInteger i, BoolT)    -> Right $ BoolN (i == 1) BoolT-          (SqlInt32 i, BoolT)      -> Right $ BoolN (i == 1) BoolT-          (SqlInt64 i, BoolT)      -> Right $ BoolN (i == 1) BoolT-          (SqlWord32 i, BoolT)     -> Right $ BoolN (i == 1) BoolT-          (SqlWord64 i, BoolT)     -> Right $ BoolN (i == 1) BoolT--          (SqlString s, TextT)     -> Right $ TextN (T.pack s) TextT-          (SqlByteString s, TextT) -> Right $ TextN (T.decodeUtf8 s) TextT--          (SqlChar c, CharT) -> Right $ CharN c CharT-          (SqlString (c : _), CharT) -> Right $ CharN c CharT-          (SqlByteString ((T.unpack . T.decodeUtf8) -> (c : _)), CharT)  -> Right $ CharN c CharT--          _                        -> $impossible--instance Convertible Norm SqlValue where-    safeConvert n =-        case n of-             UnitN _             -> Right $ SqlNull-             IntegerN i _        -> Right $ SqlInteger i-             DoubleN d _         -> Right $ SqlDouble d-             BoolN b _           -> Right $ SqlBool b-             CharN c _           -> Right $ SqlChar c-             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)

@@ -0,0 +1,647 @@+module Database.DSH.Externals where++import Database.DSH.Internals+import Database.DSH.Impossible+import Database.DSH.TH++import Prelude ( Eq, Ord, Num(..), Fractional(..), Show(..)+               , Bool(..), Char, Integer, Double, String, Maybe(..), Either(..)+               , id, undefined, ($), (.))+import qualified Prelude as P++import Data.String+import Data.Text (Text)+import qualified Data.Text as T++-- QA Instances++instance QA () where+  type Rep () = ()+  toExp () = UnitE+  frExp UnitE = ()+  frExp _ = $impossible++instance QA Bool where+  type Rep Bool = Bool+  toExp = BoolE+  frExp (BoolE b) = b+  frExp _ = $impossible++instance QA Char where+  type Rep Char = Char+  toExp = CharE+  frExp (CharE c) = c+  frExp _ = $impossible++instance QA Integer where+  type Rep Integer = Integer+  toExp = IntegerE+  frExp (IntegerE i) = i+  frExp _ = $impossible++instance QA Double where+  type Rep Double = Double+  toExp = DoubleE+  frExp (DoubleE d) = d+  frExp _ = $impossible++instance QA Text where+  type Rep Text = Text+  toExp = TextE+  frExp (TextE t) = t+  frExp _ = $impossible++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 [a] where+  type Rep [a] = [Rep a]+  toExp as = ListE (P.map toExp as)+  frExp (ListE as) = P.map frExp as+  frExp _ = $impossible++instance (QA a) => QA (Maybe a) where+  type Rep (Maybe a) = [Rep a]+  toExp Nothing = ListE []+  toExp (Just a) = ListE [toExp a]+  frExp (ListE []) = Nothing+  frExp (ListE (a : _)) = Just (frExp a)+  frExp _ = $impossible++instance (QA a,QA b) => QA (Either a b) where+  type Rep (Either a b) = ([Rep a],[Rep b])+  toExp (Left a) = PairE (ListE [toExp a]) (ListE [])+  toExp (Right b) = PairE (ListE []) (ListE [toExp b])+  frExp (PairE (ListE (a : _)) _) = Left (frExp a)+  frExp (PairE _ (ListE (a : _))) = Right (frExp a)+  frExp _ = $impossible++-- Elim instances++instance (QA r) => Elim () r where+  type Eliminator () r = Q r -> Q r+  elim _ r = r++instance (QA r) => Elim Bool r where+  type Eliminator Bool r = Q r -> Q r -> Q r+  elim (Q e) (Q e1) (Q e2) = Q (AppE Cond (PairE e (PairE e1 e2)))++instance (QA r) => Elim Char r where+  type Eliminator Char r = (Q Char -> Q r) -> Q r+  elim q f = f q++instance (QA r) => Elim Integer r where+  type Eliminator Integer r = (Q Integer -> Q r) -> Q r+  elim q f = f q++instance (QA r) => Elim Double r where+  type Eliminator Double r = (Q Double -> Q r) -> Q r+  elim q f = f q++instance (QA r) => Elim Text r where+  type Eliminator Text r = (Q Text -> Q r) -> Q r+  elim q f = f q++instance (QA a,QA b,QA r) => Elim (a,b) r where+  type Eliminator (a,b) r = (Q a -> Q b -> Q r) -> Q r+  elim q f = f (fst q) (snd q)++instance (QA a,QA r) => Elim (Maybe a) r where+  type Eliminator (Maybe a) r = Q r -> (Q a -> Q r) -> Q r+  elim q r f = maybe r f q++instance (QA a,QA b,QA r) => Elim (Either a b) r where+  type Eliminator (Either a b) r = (Q a -> Q r) -> (Q b -> Q r) -> Q r+  elim q f g = either f g q++-- BasicType instances++instance BasicType () where+instance BasicType Bool where+instance BasicType Char where+instance BasicType Integer where+instance BasicType Double where+instance BasicType Text where++-- TA instances++instance TA () where+instance TA Bool where+instance TA Char where+instance TA Integer where+instance TA Double where+instance TA Text where+instance (BasicType a, BasicType b) => TA (a,b) where++-- Num and Fractional instances++instance Num (Exp Integer) where+  (+) e1 e2 = AppE Add (PairE e1 e2)+  (*) e1 e2 = AppE Mul (PairE e1 e2)+  (-) e1 e2 = AppE Sub (PairE e1 e2)++  fromInteger = IntegerE++  abs e = let c = AppE Lt (PairE e 0)+          in  AppE Cond (PairE c (PairE (negate e) e))++  signum e = let c1 = AppE Lt  (PairE e 0)+                 c2 = AppE Equ (PairE e 0)+                 e' = AppE Cond (PairE c2 (PairE 0 1))+             in  AppE Cond (PairE c1 (PairE (-1) e'))++instance Num (Exp Double) where+  (+) e1 e2 = AppE Add (PairE e1 e2)+  (*) e1 e2 = AppE Mul (PairE e1 e2)+  (-) e1 e2 = AppE Sub (PairE e1 e2)++  fromInteger = DoubleE . fromInteger++  abs e = let c = AppE Lt (PairE e 0)+          in  AppE Cond (PairE c (PairE (negate e) e))++  signum e = let c1 = AppE Lt  (PairE e 0.0)+                 c2 = AppE Equ (PairE e 0.0)+                 e' = AppE Cond (PairE c2 (PairE 0 1))+             in  AppE Cond (PairE c1 (PairE (-1) e'))++instance Fractional (Exp Double) where+  (/) e1 e2    = AppE Div (PairE e1 e2)+  fromRational = DoubleE . fromRational++instance Num (Q Integer) where+  (+) (Q e1) (Q e2) = Q (e1 + e2)+  (*) (Q e1) (Q e2) = Q (e1 * e2)+  (-) (Q e1) (Q e2) = Q (e1 - e2)+  fromInteger       = Q . IntegerE+  abs (Q e)         = Q (abs e)+  signum (Q e)      = Q (signum e)++instance Num (Q Double) where+  (+) (Q e1) (Q e2) = Q (e1 + e2)+  (*) (Q e1) (Q e2) = Q (e1 * e2)+  (-) (Q e1) (Q e2) = Q (e1 - e2)+  fromInteger       = Q . DoubleE . fromInteger+  abs (Q e)         = Q (abs e)+  signum (Q e)      = Q (signum e)++instance Fractional (Q Double) where+  (/) (Q e1) (Q e2) = Q (e1 / e2)+  fromRational = Q . DoubleE . fromRational++-- View instances++instance View (Q ()) (Q ()) where+  type ToView (Q ()) = Q ()+  type FromView (Q ()) = Q ()+  view = id+  fromView = id++instance View (Q Bool) (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+  type ToView (Q Char) = Q Char+  type FromView (Q Char) = Q Char+  view = id+  fromView = id++instance View (Q Integer) (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+  type ToView (Q Double) = Q Double+  type FromView (Q Double) = Q Double+  view = id+  fromView = id++instance View (Q Text) (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+  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)++-- IsString instances++instance IsString (Q Text) where+  fromString = Q . TextE . T.pack++-- * Referring to persistent tables++table :: (QA a, TA a) => String -> Q [a]+table name = Q (TableE (TableDB name []))++tableDB :: (QA a, TA a) => String -> Q [a]+tableDB name = Q (TableE (TableDB name []))++tableWithKeys :: (QA a, TA a) => String -> [[String]] -> Q [a]+tableWithKeys name keys = Q (TableE (TableDB name keys))++tableCSV :: (QA a, TA a) => String -> Q [a]+tableCSV filename = Q (TableE (TableCSV filename))++-- * toQ++toQ :: (QA a) => a -> Q a+toQ = Q . toExp++-- * Unit++unit :: Q ()+unit = Q UnitE++-- * Boolean logic++false :: Q Bool+false = Q (BoolE False)++true :: Q Bool+true = Q (BoolE True)++not :: Q Bool -> Q Bool+not (Q e) = Q (AppE Not e)++(&&) :: Q Bool -> Q Bool -> Q Bool+(&&) (Q a) (Q b) = Q (AppE Conj (PairE a b))++(||) :: Q Bool -> Q Bool -> Q Bool+(||) (Q a) (Q b) = Q (AppE Disj (PairE a b))++-- * Equality and Ordering++eq :: (QA a,Eq a) => Q a -> Q a -> Q Bool+eq (Q a) (Q b) = Q (AppE Equ (PairE a b))++(==) :: (QA a,Eq a) => Q a -> Q a -> Q Bool+(==) = eq++neq :: (QA a,Eq a) => Q a -> Q a -> Q Bool+neq a b = not (eq a b)++(/=) :: (QA a,Eq a) => Q a -> Q a -> Q Bool+(/=) = neq++lt :: (QA a,Ord a) => Q a -> Q a -> Q Bool+lt (Q a) (Q b) = Q (AppE Lt (PairE a b))++(<) :: (QA a,Ord a) => Q a -> Q a -> Q Bool+(<) = lt++lte :: (QA a,Ord a) => Q a -> Q a -> Q Bool+lte (Q a) (Q b) = Q (AppE Lte (PairE a b))++(<=) :: (QA a,Ord a) => Q a -> Q a -> Q Bool+(<=) = lte++gte :: (QA a,Ord a) => Q a -> Q a -> Q Bool+gte (Q a) (Q b) = Q (AppE Gte (PairE a b))++(>=) :: (QA a,Ord a) => Q a -> Q a -> Q Bool+(>=) = gte++gt :: (QA a,Ord a) => Q a -> Q a -> Q Bool+gt (Q a) (Q b) = Q (AppE Gt (PairE a b))++(>) :: (QA a,Ord a) => Q a -> Q a -> Q Bool+(>) = gt++min :: (QA a,Ord a) => Q a -> Q a -> Q a+min (Q a) (Q b) = Q (AppE Min (PairE a b))++max :: (QA a,Ord a) => Q a -> Q a -> Q a+max (Q a) (Q b) = Q (AppE Max (PairE a b))++-- * Conditionals++bool :: (QA a) => Q a -> Q a -> Q Bool -> Q a+bool f t b = cond b t f++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)))++(?) :: (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 = concatMap maybeToList++mapMaybe :: (QA a,QA b) => (Q a -> Q (Maybe b)) -> Q [a] -> Q [b]+mapMaybe f = concatMap (maybeToList . f)++-- * Either++pairToEither :: (QA a,QA b) => Q ([a],[b]) -> Q (Either a b)+pairToEither (Q a) = Q a++eitherToPair :: (QA a,QA b) => Q (Either a b) -> Q ([a],[b])+eitherToPair (Q a) = Q a++left :: (QA a,QA b) => Q a -> Q (Either a b)+left a = pairToEither (tuple (singleton a,nil))++right :: (QA a,QA b) => Q b -> Q (Either a b)+right a = pairToEither (tuple (nil,singleton a))++isLeft :: (QA a,QA b) => Q (Either a b) -> Q Bool+isLeft = null . snd . eitherToPair++isRight :: (QA a,QA b) => Q (Either a b) -> Q Bool+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)++lefts :: (QA a,QA b) => Q [Either a b] -> Q [a]+lefts = concatMap (fst . eitherToPair)++rights :: (QA a,QA b) => Q [Either a b] -> Q [b]+rights = concatMap (snd . eitherToPair)++partitionEithers :: (QA a,QA b) => Q [Either a b] -> Q ([a], [b])+partitionEithers es = tuple (lefts es,rights es)++-- * List Construction++nil :: (QA a) => Q [a]+nil = Q (ListE [])++empty :: (QA a) => Q [a]+empty = nil++cons :: (QA a) => Q a -> Q [a] -> Q [a]+cons (Q a) (Q as) = Q (AppE Cons (PairE a as))++(<|) :: (QA a) => Q a -> Q [a] -> Q [a]+(<|) = cons++snoc :: (QA a) => Q [a] -> Q a -> Q [a]+snoc as a = append as (singleton a)++(|>) :: (QA a) => Q [a] -> Q a -> Q [a]+(|>) = snoc++singleton :: (QA a) => Q a -> Q [a]+singleton (Q e) = cons (Q e) nil++-- * List Operations++head :: (QA a) => Q [a] -> Q a+head (Q as) = Q (AppE Head as)++tail :: (QA a) => Q [a] -> Q [a]+tail (Q as) = Q (AppE Tail as)++take :: (QA a) => Q Integer -> Q [a] -> Q [a]+take (Q i) (Q as) = Q (AppE Take (PairE i as))++drop :: (QA a) => Q Integer -> Q [a] -> Q [a]+drop (Q i) (Q as) = Q (AppE Drop (PairE i as))++map :: (QA a,QA b) => (Q a -> Q b) ->  Q [a] -> Q [b]+map f (Q as) = Q (AppE Map (PairE (LamE (toLam f)) as))++append :: (QA a) => Q [a] -> Q [a] -> Q [a]+append (Q as) (Q bs) = Q (AppE Concat (ListE [as,bs]))++(++) :: (QA a) => Q [a] -> Q [a] -> Q [a]+(++) = append++filter :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a]+filter f (Q as) = Q (AppE Filter (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))++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)++init :: (QA a) => Q [a] -> Q [a]+init (Q as) = Q (AppE Init as)++null :: (QA a) => Q [a] -> Q Bool+null (Q as) = Q (AppE Null as)++length :: (QA a) => Q [a] -> Q Integer+length (Q as) = Q (AppE Length as)++index :: (QA a) => Q [a] -> Q Integer -> Q a+index (Q as) (Q i) = Q (AppE Index (PairE as i))++(!!) :: (QA a) => Q [a] -> Q Integer -> Q a+(!!) = index++reverse :: (QA a) => Q [a] -> Q [a]+reverse (Q as) = Q (AppE Reverse as)++-- * Special folds++and :: Q [Bool] -> Q Bool+and (Q bs) = Q (AppE And bs)++or :: Q [Bool] -> Q Bool+or (Q bs) = Q (AppE Or bs)++any :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q Bool+any f = or . map f++all :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q Bool+all f = and . map f++sum :: (QA a,Num a) => Q [a] -> Q a+sum (Q as) = Q (AppE Sum as)++concat :: (QA a) => Q [[a]] -> Q [a]+concat (Q ass) = Q (AppE Concat ass)++concatMap :: (QA a,QA b) => (Q a -> Q [b]) -> Q [a] -> Q [b]+concatMap f as = concat (map f as)++maximum :: (QA a,Ord a) => Q [a] -> Q a+maximum (Q as) = Q (AppE Maximum as)++minimum :: (QA a,Ord a) => Q [a] -> Q a+minimum (Q as) = Q (AppE Minimum as)++-- * Sublists++splitAt :: (QA a) => Q Integer -> Q [a] -> Q ([a],[a])+splitAt (Q i) (Q as) = Q (AppE SplitAt (PairE i as))++takeWhile :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a]+takeWhile f (Q as) = Q (AppE TakeWhile (PairE (LamE (toLam f)) as))++dropWhile :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a]+dropWhile f (Q as) = Q (AppE DropWhile (PairE (LamE (toLam f)) as))++span :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q ([a],[a])+span f as = pair (takeWhile f as) (dropWhile f as)++break :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q ([a],[a])+break f = span (not . f)++-- * Searching Lists++elem :: (QA a,Eq a) => Q a -> Q [a] -> Q Bool+elem a as = null (filter (a ==) as) ? (false,true)++notElem :: (QA a,Eq a) => Q a -> Q [a] -> Q Bool+notElem a as = not (a `elem` 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 :: (QA a,QA b) => Q [a] -> Q [b] -> Q [(a,b)]+zip (Q as) (Q bs) = Q (AppE Zip (PairE as bs))++zipWith :: (QA a,QA b,QA c) => (Q a -> Q b -> Q c) -> Q [a] -> Q [b] -> Q [c]+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)++-- * Set-oriented operations++nub :: (QA a,Eq a) => Q [a] -> Q [a]+nub (Q as) = Q (AppE Nub as)++-- * Tuple Projection Functions++fst :: (QA a,QA b) => Q (a,b) -> Q a+fst (Q e) = Q (AppE Fst e)++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+integerToDouble (Q i) = Q (AppE IntegerToDouble i)++-- * 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++-- * Construction of tuples and records++tuple :: (View a b) => b -> a+tuple = fromView++record :: (View a b) => b -> a+record = fromView++infixl 9  !!+infixr 5  ++, <|, |>+infix  4  ==, /=, <, <=, >=, >+infixr 3  &&+infixr 2  ||+infix  0  ?++deriveTupleRangeQA 3 16++-- * Missing functions++-- $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++-}

@@ -7,4 +7,4 @@   loc <- TH.location   let pos =  (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc))   let message = "DSH: Impossbile happend at " ++ show pos-  return (TH.AppE (TH.VarE (TH.mkName "error")) (TH.LitE (TH.StringL message)))+  return (TH.AppE (TH.VarE 'error) (TH.LitE (TH.StringL message)))

@@ -0,0 +1,204 @@+module Database.DSH.Internals where++import Data.Text (Text)++data Exp a where+  UnitE     :: Exp ()+  BoolE     :: Bool    -> Exp Bool+  CharE     :: Char    -> Exp Char+  IntegerE  :: Integer -> Exp Integer+  DoubleE   :: Double  -> Exp Double+  TextE     :: Text    -> Exp Text+  PairE     :: (Reify a, Reify b)  => Exp a -> Exp b -> Exp (a,b)+  ListE     :: (Reify a)           => [Exp a] -> Exp [a]+  AppE      :: (Reify a, Reify b)  => Fun a b -> Exp a -> Exp b+  LamE      :: (Reify a, Reify b)  => (Exp a -> Exp b) -> Exp (a -> b)+  VarE      :: (Reify a)           => Integer -> Exp a+  TableE    :: (Reify a)           => Table -> Exp [a]++data Table = TableDB String [[String]] | TableCSV  String deriving (Eq, Ord, Show)++data Type a where+  UnitT     :: Type ()+  BoolT     :: Type Bool+  CharT     :: Type Char+  IntegerT  :: Type Integer+  DoubleT   :: Type Double+  TextT     :: Type Text+  PairT     :: (Reify a,Reify b)  => Type a -> Type b -> Type (a,b)+  ListT     :: (Reify a)          => Type a -> Type [a]+  ArrowT    :: (Reify a,Reify b)  => Type a -> Type b -> Type (a -> b)++data Fun a b where+    Not             :: Fun Bool Bool+    IntegerToDouble :: Fun Integer Double+    And             :: Fun [Bool] Bool+    Or              :: Fun [Bool] Bool+    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+    Length          :: Fun [a] Integer+    Reverse         :: Fun [a] [a]+    Fst             :: Fun (a,b) a+    Snd             :: Fun (a,b) b+    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+    Sub             :: Fun (a,a) a+    Div             :: Fun (a,a) a+    Lt              :: Fun (a,a) Bool+    Lte             :: Fun (a,a) Bool+    Equ             :: Fun (a,a) Bool+    Gte             :: Fun (a,a) Bool+    Gt              :: Fun (a,a) Bool+    Conj            :: Fun (Bool,Bool) Bool+    Disj            :: Fun (Bool,Bool) Bool+    Min             :: Fun (a,a) a+    Max             :: Fun (a,a) a+    Cons            :: Fun (a,[a]) [a]+    Take            :: Fun (Integer,[a]) [a]+    Drop            :: Fun (Integer,[a]) [a]+    Index           :: Fun ([a],Integer) a+    SplitAt         :: Fun (Integer,[a]) ([a],[a])+    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]]+    SortWith        :: Fun (a -> b,[a]) [a]+    TakeWhile       :: Fun (a -> Bool,[a]) [a]+    DropWhile       :: Fun (a -> Bool,[a]) [a]+    Cond            :: Fun (Bool,(a,a)) a++data Q a where+  Q :: Exp (Rep a) -> Q a++-- Classes++class Reify a where+  reify :: a -> Type a++class (Reify (Rep a)) => QA a where+  type Rep a+  toExp :: a -> Exp (Rep a)+  frExp :: Exp (Rep a) -> a++class (QA a,QA r) => Elim a r where+  type Eliminator a r+  elim :: Q a -> Eliminator a r++class BasicType a where++class TA a where++class (ToView a ~ b, FromView b ~ a) => View a b where+  type ToView a+  type FromView b+  view :: a -> b+  fromView :: b -> a++-- Show instances++instance Show (Type a) where+  show UnitT = "()"+  show BoolT = "Bool"+  show CharT = "Char"+  show IntegerT = "Integer"+  show DoubleT = "Double"+  show TextT = "Text"+  show (PairT l r) = "(" ++ show l ++ ", " ++ show r ++ ")"+  show (ListT t) = "[" ++ show t ++ "]"+  show (ArrowT t1 t2) = "(" ++ show t1 ++ " -> " ++ show t2 ++ ")"++instance Show (Fun a b) where+    show Fst = "fst"+    show Snd = "snd"+    show Not = "not"+    show Concat = "concat"+    show Head = "head"+    show Tail = "tail"+    show The = "the"+    show Init = "init"+    show Last = "last"+    show Null = "null"+    show Length = "length"+    show Reverse = "reverse"+    show And = "and"+    show Or = "or"+    show Sum = "sum"+    show Maximum = "maximum"+    show Minimum = "minimum"+    show Unzip = "unzip"+    show Nub = "nub"+    show IntegerToDouble = "integerToDouble"+    show Add = "+"+    show Mul = "*"+    show Sub = "-"+    show Div = "/"+    show Lt  = "<"+    show Lte = "<="+    show Equ = "=="+    show Gte = ">="+    show Gt  = ">"+    show Conj = "&&"+    show Disj = "||"+    show Min  = "min"+    show Max  = "max"+    show Cons = "cons"+    show Take = "take"+    show Drop = "drop"+    show Index = "index"+    show SplitAt = "splitAt"+    show Zip = "zip"+    show Map = "map"+    show Filter = "filter"+    show GroupWith = "groupWith"+    show SortWith = "sortWith"+    show TakeWhile = "takeWhile"+    show DropWhile = "dropWhile"+    show Cond = "cond"++-- Reify instances++instance Reify () where+  reify _ = UnitT++instance Reify Bool where+  reify _ = BoolT++instance Reify Char where+  reify _ = CharT++instance Reify Integer where+  reify _ = IntegerT++instance Reify Double where+  reify _ = DoubleT++instance Reify Text where+  reify _ = TextT++instance (Reify a, Reify b) => Reify (a,b) where+  reify _ = PairT (reify (undefined :: a)) (reify (undefined :: b))++instance (Reify a) => Reify [a] where+  reify _ = ListT (reify (undefined :: a))++instance (Reify a, Reify b) => Reify (a -> b) where+  reify _ = ArrowT (reify (undefined :: a)) (reify (undefined :: b))+++-- Utility functions++unQ :: Q a -> Exp (Rep a)+unQ (Q e) = e++toLam :: (QA a,QA b) => (Q a -> Q b) -> Exp (Rep a) -> Exp (Rep b)+toLam f = unQ . f . Q

@@ -1,394 +1,385 @@ -- | This module provides the reference implementation of DSH by interpreting -- the embedded representation. -{-# LANGUAGE TemplateHaskell, ViewPatterns, ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}- module Database.DSH.Interpreter (fromQ) where -import Database.DSH.Data-import Database.DSH.Impossible (impossible)-import Database.DSH.CSV (csvImport)+import Database.DSH.Internals+import Database.DSH.Impossible+import Database.DSH.CSV -import Data.Convertible+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Database.HDBC-import GHC.Exts import Data.List  fromQ :: (QA a, IConnection conn) => conn -> Q a -> IO a-fromQ c (Q a) = evaluate c a >>= (return . fromNorm)+fromQ c (Q e) = fmap frExp (evaluate c e) -evaluate :: IConnection conn-         => conn                -- ^ The HDBC connection-         -> Exp-         -> IO Norm+evaluate :: forall a conn. (Reify a, IConnection conn) => conn -> Exp a -> IO (Exp a) evaluate c e = case e of-  UnitE t      -> return (UnitN t)-  BoolE b t    -> return (BoolN b t)-  CharE ch t   -> return (CharN ch t)-  IntegerE i t -> return (IntegerN i t)-  DoubleE d t  -> return (DoubleN d t)-  TextE s t    -> return (TextN s t)--  VarE _ _ -> $impossible-  LamE _ _ -> $impossible--  TupleE e1 e2 t -> do-    e3 <- evaluate c e1-    e4 <- evaluate c e2-    return (TupleN e3 e4 t)--  ListE es t -> do-      es1 <- mapM (evaluate c) es-      return (ListN es1 t)--  AppE3 Cond cond a b _ -> do-      (BoolN c1 _) <- evaluate c cond+    UnitE -> return UnitE+    BoolE b -> return $ BoolE b+    CharE ch -> return $ CharE ch+    IntegerE i -> return $ IntegerE i+    DoubleE d -> return $ DoubleE d+    TextE t -> return $ TextE t +    VarE _ -> $impossible+    LamE _ -> $impossible+    PairE e1 e2 -> do+      e1' <- evaluate c e1+      e2' <- evaluate c e2+      return (PairE e1' e2')+    ListE es -> do+       es1 <- mapM (evaluate c) es+       return $ ListE es1 +    AppE Cond (PairE cond (PairE a b)) -> do+      (BoolE c1) <- evaluate c cond       if c1 then evaluate c a else evaluate c b--  AppE2 Cons a as t -> do-    a1 <- evaluate c a-    (ListN as1 _) <- evaluate c as-    return $ ListN (a1 : as1) t--  AppE2 Snoc as a t -> do-    a1 <- evaluate c a-    (ListN as1 _) <- evaluate c as-    return $ ListN (snoc as1 a1) t--  AppE1 Head as _ -> do-    (ListN as1 _) <- evaluate c as-    return $ head as1--  AppE1 Tail as t -> do-    (ListN as1 _) <- evaluate c as-    return $ ListN (tail as1) t--  AppE2 Take i as t -> do-    (IntegerN i1 _) <- evaluate c i-    (ListN as1 _) <- evaluate c as-    return $ ListN (take (fromIntegral i1) as1) t--  AppE2 Drop i as t -> do-    (IntegerN i1 _) <- evaluate c i-    (ListN as1 _) <- evaluate c as-    return $ ListN (drop (fromIntegral i1) as1) t--  AppE2 Map lam as t -> do-    (ListN as1 _) <- evaluate c as-    evaluate c $ ListE (map (evalLam lam) as1) t--  AppE2 Append as bs t -> do-    (ListN as1 _) <- evaluate c as-    (ListN bs1 _) <- evaluate c bs-    return $ ListN (as1 ++ bs1) t--  AppE2 Filter lam as t -> do-    (ListN as1 _) <- evaluate c as-    (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (ListT BoolT))-    return $ ListN (map fst (filter (\(_,(BoolN b BoolT)) -> b) (zip as1 as2))) t--  AppE2 GroupWith lam as t -> do-    (ListN as1 t1) <- evaluate c as-    (ListN as2 _ ) <- evaluate c (ListE (map (evalLam lam) as1) (ListT (typeArrowResult (typeExp lam))))-    return $ ListN (map ((flip ListN) t1 . (map fst)) $ groupWith snd $ zip as1 as2) t--  AppE2 SortWith lam as t -> do-    (ListN as1 _) <- evaluate c as-    (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (ListT (typeArrowResult (typeExp lam))))-    return $ ListN (map fst $ sortWith snd $ zip as1 as2) t--  AppE2 Max e1 e2 IntegerT -> do-     (IntegerN v1 _) <- evaluate c e1-     (IntegerN v2 _) <- evaluate c e2-     return $ IntegerN (max v1 v2) IntegerT--  AppE2 Max e1 e2 DoubleT -> do-     (DoubleN v1 _) <- evaluate c e1-     (DoubleN v2 _) <- evaluate c e2-     return $ DoubleN (max v1 v2) DoubleT--  AppE2 Min e1 e2 IntegerT -> do-     (IntegerN v1 _) <- evaluate c e1-     (IntegerN v2 _) <- evaluate c e2-     return $ IntegerN (min v1 v2) IntegerT--  AppE2 Min e1 e2 DoubleT -> do-     (DoubleN v1 _) <- evaluate c e1-     (DoubleN v2 _) <- evaluate c e2-     return $ DoubleN (min v1 v2) DoubleT--  AppE1 The as _ -> do-    (ListN as1 _) <- evaluate c as-    return $ the as1--  AppE1 Last as _ -> do-    (ListN as1 _) <- evaluate c as-    return $ last as1--  AppE1 Init as t -> do-    (ListN as1 _) <- evaluate c as-    return $ ListN (init as1) t--  AppE1 Null as _ -> do-    (ListN as1 _) <- evaluate c as-    return $ BoolN (null as1) BoolT--  AppE1 Length as _ -> do-    (ListN as1 _) <- evaluate c as-    return $ IntegerN (fromIntegral $ length as1) IntegerT--  AppE2 Index as i _ -> do-    (IntegerN i1 _) <- evaluate c i-    (ListN as1 _) <- evaluate c as-    return $ as1 !! (fromIntegral i1)--  AppE1 Reverse as t -> do-    (ListN as1 _) <- evaluate c as-    return $ ListN (reverse as1) t--  AppE1 And as _ -> do-    (ListN as1 _) <- evaluate c as-    return $ BoolN (and $ map (\(BoolN b BoolT) -> b) as1) BoolT--  AppE1 Or as _ -> do-    (ListN as1 _) <- evaluate c as-    return $ BoolN (or $ map (\(BoolN b BoolT) -> b) as1) BoolT--  AppE2 Any lam as _ -> do-    (ListN as1 _) <- evaluate c as-    (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (typeArrowResult (typeExp lam)))-    return $ BoolN (any id $ map (\(BoolN b BoolT) -> b) as2) BoolT--  AppE2 All lam as _ -> do-    (ListN as1 _) <- evaluate c as-    (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (typeArrowResult (typeExp lam)))-    return $ BoolN (all id $ map (\(BoolN b BoolT) -> b) as2) BoolT--  AppE1 Sum as IntegerT -> do-    (ListN as1 _) <- evaluate c as-    return $ IntegerN (sum $ map (\(IntegerN i IntegerT) -> i) as1) IntegerT--  AppE1 Sum as DoubleT -> do-    (ListN as1 _) <- evaluate c as-    return $ DoubleN (sum $ map (\(DoubleN d DoubleT) -> d) as1) DoubleT--  AppE1 Sum _ _ -> $impossible--  AppE1 Concat as t -> do-    (ListN as1 _) <- evaluate c as-    return $ ListN (concat $ map (\(ListN as2 _) -> as2) as1) t--  AppE1 Maximum as _ -> do-    (ListN as1 _) <- evaluate c as-    return $ maximum as1--  AppE1 Minimum as _ -> do-    (ListN as1 _) <- evaluate c as-    return $ minimum as1--  AppE2 SplitAt i as t -> do-    (IntegerN i1 _) <- evaluate c i-    (ListN as1 t1) <- evaluate c as-    let r = splitAt (fromIntegral i1) as1-    return $ TupleN (ListN (fst r) t1) (ListN (snd r) t1) t--  AppE2 TakeWhile lam as t -> do-    (ListN as1 _) <- evaluate c as-    (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (typeArrowResult (typeExp lam)))-    return $ ListN (map fst $ takeWhile (\(_,BoolN b BoolT) -> b) $ zip as1 as2) t--  AppE2 DropWhile lam as t -> do-    (ListN as1 _) <- evaluate c as-    (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (typeArrowResult (typeExp lam)))-    return $ ListN (map fst $ dropWhile (\(_,BoolN b BoolT) -> b) $ zip as1 as2) t--  AppE2 Span lam as t -> do-    (ListN as1 t1) <- evaluate c as-    (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (typeArrowResult (typeExp lam)))-    return $ (\(a,b) -> TupleN a b t)-           $ (\(a,b) -> (ListN (map fst a) t1, ListN (map fst b) t1))-           $ span (\(_,BoolN b BoolT) -> b)-           $ zip as1 as2--  AppE2 Break lam as t -> do-    (ListN as1 t1) <- evaluate c as-    (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (typeArrowResult (typeExp lam)))-    return $ (\(a,b) -> TupleN a b t)-           $ (\(a,b) -> (ListN (map fst a) t1, ListN (map fst b) t1))-           $ break (\(_,BoolN b BoolT) -> b)-           $ zip as1 as2--  AppE2 Zip as bs t -> do-    (ListN as1 (ListT t1)) <- evaluate c as-    (ListN bs1 (ListT t2)) <- evaluate c bs-    return $ ListN (zipWith (\a b -> TupleN a b (TupleT t1 t2)) as1 bs1) t--  AppE1 Unzip as t -> do-    (ListN as1 (ListT (TupleT t1 t2))) <- evaluate c as-    return $ TupleN (ListN (map (\(TupleN a _ _) -> a) as1) (ListT t1))-                    (ListN (map (\(TupleN _ b _) -> b) as1) (ListT t2))-                    t--  AppE3 ZipWith lam as bs t -> do-    (ListN as1 _) <- evaluate c as-    (ListN bs1 _) <- evaluate c bs-    evaluate c $ ListE (zipWith (\a b -> let lam1 = ((evalLam lam) a) in (evalLam lam1) b) as1 bs1) t--  AppE1 Nub as t -> do-    (ListN as1 _) <- evaluate c as-    return $ ListN (nub as1) t--  AppE1 Fst a _ -> do-    (TupleN a1 _ _) <- evaluate c a-    return a1--  AppE1 Snd a _ -> do-    (TupleN _ a1 _) <- evaluate c a-    return a1--  AppE2 Add e1 e2 IntegerT -> do-    (IntegerN i1 _) <- evaluate c e1-    (IntegerN i2 _) <- evaluate c e2-    return $ IntegerN (i1 + i2) IntegerT-  AppE2 Add e1 e2 DoubleT -> do-    (DoubleN d1 _) <- evaluate c e1-    (DoubleN d2 _) <- evaluate c e2-    return $ DoubleN (d1 + d2) DoubleT-  AppE2 Add _ _ _ -> $impossible--  AppE2 Sub e1 e2 IntegerT -> do-    (IntegerN i1 _) <- evaluate c e1-    (IntegerN i2 _) <- evaluate c e2-    return $ IntegerN (i1 - i2) IntegerT-  AppE2 Sub e1 e2 DoubleT -> do-    (DoubleN d1 _) <- evaluate c e1-    (DoubleN d2 _) <- evaluate c e2-    return $ DoubleN (d1 - d2) DoubleT-  AppE2 Sub _ _ _ -> $impossible--  AppE2 Mul e1 e2 IntegerT -> do-    (IntegerN i1 _) <- evaluate c e1-    (IntegerN i2 _) <- evaluate c e2-    return $ IntegerN (i1 * i2) IntegerT-  AppE2 Mul e1 e2 DoubleT -> do-    (DoubleN d1 _) <- evaluate c e1-    (DoubleN d2 _) <- evaluate c e2-    return $ DoubleN (d1 * d2) DoubleT-  AppE2 Mul _ _ _ -> $impossible-  -  AppE2 Div e1 e2 DoubleT -> do-    (DoubleN d1 _) <- evaluate c e1-    (DoubleN d2 _) <- evaluate c e2-    return $ DoubleN (d1 / d2) DoubleT-  AppE2 Div _ _ _ -> $impossible-  -  AppE1 IntegerToDouble e1 DoubleT -> do-    (IntegerN i1 _) <- evaluate c e1-    return $ DoubleN (fromInteger i1) DoubleT-    -  AppE1 IntegerToDouble _ _ -> $impossible--  AppE2 Equ e1 e2 _ -> do-    e3 <- evaluate c e1-    e4 <- evaluate c e2-    return $ BoolN (e3 == e4) BoolT--  AppE2 Lt e1 e2 _ -> do-    e3 <- evaluate c e1-    e4 <- evaluate c e2-    return $ BoolN (e3 < e4) BoolT--  AppE2 Lte e1 e2 _ -> do-    e3 <- evaluate c e1-    e4 <- evaluate c e2-    return $ BoolN (e3 <= e4) BoolT--  AppE2 Gte e1 e2 _ -> do-    e3 <- evaluate c e1-    e4 <- evaluate c e2-    return $ BoolN (e3 >= e4) BoolT--  AppE2 Gt e1 e2 _ -> do-    e3 <- evaluate c e1-    e4 <- evaluate c e2-    return $ BoolN (e3 > e4) BoolT+    AppE Cons (PairE a as) -> do+      a1 <- evaluate c a+      (ListE as1) <- evaluate c as+      return $ ListE (a1 : as1)+    AppE Head as -> do+      (ListE as1) <- evaluate c as+      return $ head as1+    AppE Tail as -> do+      (ListE as1) <- evaluate c as+      return $ ListE (tail as1)+    AppE Take (PairE i as) -> do+      (IntegerE i1) <- evaluate c i+      (ListE as1) <- evaluate c as+      return $ ListE (take (fromIntegral i1) as1)+    AppE Drop (PairE i as) -> do+      (IntegerE i1) <- evaluate c i+      (ListE as1) <- evaluate c as+      return $ ListE (drop (fromIntegral i1) as1)+    AppE Map (PairE (LamE f) as) -> do+      (ListE as1) <- evaluate c as+      evaluate c $ ListE (map f as1)+    AppE Filter (PairE (LamE f) as) -> do+      (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+      (ListE as1) <- evaluate c as+      (ListE as2) <- 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+    AppE SortWith (PairE (LamE f) as) -> do+      (ListE as1) <- evaluate c as+      (ListE as2) <- evaluate c $ ListE (map f as1) +      return $ ListE +             $ map fst+             $ sortBy (\(_,a1) (_,a2) -> compareExp a1 a2)+             $ 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)+          _ -> $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)+          _ -> $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+    AppE Init as -> do+      (ListE as1) <- evaluate c as+      return $ ListE (init as1)+    AppE Null as -> do+      (ListE as1) <- evaluate c as+      return $ BoolE (null as1)+    AppE Length as -> do+     (ListE as1) <- evaluate c as+     return $ IntegerE (fromIntegral $ length as1)+    AppE Index (PairE as i) -> do+     (IntegerE i1) <- evaluate c i+     (ListE as1) <- evaluate c as+     return $ as1 !! fromIntegral i1+    AppE Reverse as -> do+      (ListE as1) <- evaluate c as+      return $ ListE (reverse as1)+    AppE And as -> do+      (ListE as1) <- evaluate c as+      return $ BoolE (all (\(BoolE b) -> b) as1)+    AppE Or as -> do+      (ListE as1) <- evaluate c as+      return $ BoolE (any (\(BoolE b) -> b) as1)+    (AppE Sum as) -> do+      let ty = reify (undefined :: a)+      (ListE as1) <- evaluate c as+      case ty of+          IntegerT -> return $ IntegerE (sum $ map (\(IntegerE i) -> i) as1)+          DoubleT  -> return $ DoubleE (sum $ map (\(DoubleE d) -> d) as1)+          _ -> $impossible+    AppE Concat as -> do+      (ListE as1) <- evaluate c as+      return $ ListE (concatMap (\(ListE as2) -> as2) as1)+    AppE Maximum as -> do+      (ListE as1) <- evaluate c as+      return $ maximumBy compareExp as1+    AppE Minimum as -> do+      (ListE as1) <- evaluate c as+      return $ minimumBy compareExp as1+    AppE SplitAt (PairE i as) -> do+      (IntegerE i1) <- evaluate c i+      (ListE as1) <- evaluate c as+      let r = splitAt (fromIntegral i1) as1+      return $ PairE (ListE (fst r)) (ListE (snd r)) +    AppE TakeWhile (PairE (LamE f) as) -> do+      (ListE as1) <- evaluate c as+      (ListE as2) <- evaluate c (ListE (map f as1))+      return $ ListE (map fst $ takeWhile (\(_,BoolE b) -> b) $ zip as1 as2)+    AppE DropWhile (PairE (LamE f) as) -> do+      (ListE as1) <- evaluate c as+      (ListE as2) <- evaluate c (ListE (map f as1))+      return $ ListE (map fst $ dropWhile (\(_,BoolE b) -> b) $ zip as1 as2)+    AppE Zip (PairE as bs) -> do+      (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)+    AppE Fst a -> do+      (PairE a1 _) <- evaluate c a+      return a1+    AppE Snd a -> do+      (PairE _ a1) <- evaluate c a+      return a1+    (AppE Add (PairE e1 e2)) -> do+      let ty = reify (undefined :: a)+      case ty of+         IntegerT -> do+                      (IntegerE i1) <- evaluate c e1+                      (IntegerE i2) <- evaluate c e2+                      return $ IntegerE (i1 + i2)+         DoubleT  -> do+                      (DoubleE d1) <- evaluate c e1+                      (DoubleE d2) <- evaluate c e2+                      return $ DoubleE (d1 + d2)+         _ -> $impossible+    (AppE Sub (PairE e1 e2)) -> do+      let ty = reify (undefined :: a)+      case ty of+         IntegerT -> do+                      (IntegerE i1) <- evaluate c e1+                      (IntegerE i2) <- evaluate c e2+                      return $ IntegerE (i1 - i2)+         DoubleT  -> do+                      (DoubleE d1) <- evaluate c e1+                      (DoubleE d2) <- evaluate c e2+                      return $ DoubleE (d1 - d2)+         _ -> $impossible+    (AppE Mul (PairE e1 e2)) -> do+      let ty = reify (undefined :: a)+      case ty of+         IntegerT -> do+                      (IntegerE i1) <- evaluate c e1+                      (IntegerE i2) <- evaluate c e2+                      return $ IntegerE (i1 * i2)+         DoubleT  -> do+                      (DoubleE d1) <- evaluate c e1+                      (DoubleE d2) <- evaluate c e2+                      return $ DoubleE (d1 * d2)+         _ -> $impossible+    (AppE Div (PairE e1 e2)) -> do+      let ty = reify (undefined :: a)+      case ty of+         DoubleT  -> do+                      (DoubleE d1) <- evaluate c e1+                      (DoubleE d2) <- evaluate c e2+                      return $ DoubleE (d1 / d2)+         _ -> $impossible+    AppE IntegerToDouble e1 -> do+      (IntegerE i1) <- evaluate c e1+      return $ DoubleE (fromInteger i1)+    AppE Equ (PairE e1 e2) -> do+      e3 <- evaluate c e1+      e4 <- evaluate c e2+      return $ BoolE $ equExp e3 e4+    AppE Lt (PairE e1 e2) -> do+      e3 <- evaluate c e1+      e4 <- evaluate c e2+      return $ BoolE $ ltExp e3 e4+    AppE Lte (PairE e1 e2) -> do+      e3 <- evaluate c e1+      e4 <- evaluate c e2+      return $ BoolE $ lteExp e3 e4+    AppE Gte (PairE e1 e2) -> do+      e3 <- evaluate c e1+      e4 <- evaluate c e2+      return $ BoolE $ gteExp e3 e4+    AppE Gt (PairE e1 e2) -> do+      e3 <- evaluate c e1+      e4 <- evaluate c e2+      return $ BoolE $ gtExp e3 e4+    AppE Not e1 -> do+      (BoolE b1) <- evaluate c e1+      return $ BoolE (not b1)+    AppE Conj (PairE e1 e2) -> do+      (BoolE b1) <- evaluate c e1+      (BoolE b2) <- evaluate c e2+      return $ BoolE (b1 && b2)+    AppE Disj (PairE e1 e2) -> do+      (BoolE b1) <- evaluate c e1+      (BoolE b2) <- evaluate c e2+      return $ BoolE (b1 || b2) +    (TableE (TableDB tName _)) -> +      let ty = reify (undefined :: a)+      in case ty of+          ListT tType -> do+            tDesc <- describeTable c (escape tName)+            let columnNames = intercalate " , " $ map (\s -> "\"" ++ s ++ "\"") $ sort $ map fst tDesc+            let query = "SELECT " ++ columnNames ++ " FROM " ++ "\"" ++ escape tName ++ "\""+            -- print query+            fmap (sqlToExpWithType (escape tName) tType) (quickQuery c query [])+          _ -> $impossible+    (TableE (TableCSV filename)) -> csvImport filename (reify (undefined :: a))+    _ -> $impossible -  AppE1 Not e1 _ -> do-    (BoolN b1 _) <- evaluate c e1-    return $ BoolN (not b1) BoolT+compareExp :: Exp a -> Exp a -> Ordering+compareExp UnitE UnitE                       = EQ+compareExp (BoolE v1) (BoolE v2)             = compare v1 v2+compareExp (CharE v1) (CharE v2)             = compare v1 v2+compareExp (IntegerE v1) (IntegerE v2)       = compare v1 v2+compareExp (DoubleE v1) (DoubleE v2)         = compare v1 v2+compareExp (TextE v1) (TextE v2)             = compare v1 v2+compareExp (PairE a1 b1) (PairE a2 b2)       = case compareExp a1 a2 of+                                                 EQ -> compareExp b1 b2+                                                 LT -> LT+                                                 GT -> GT+compareExp (ListE []) (ListE [])             = EQ+compareExp (ListE (_ : _)) (ListE [])        = GT+compareExp (ListE []) (ListE (_ : _))        = LT+compareExp (ListE (a : as)) (ListE (b : bs)) = case compareExp a b of+                                                 EQ -> compareExp (ListE as) (ListE bs)+                                                 LT -> LT+                                                 GT -> GT+compareExp _ _ = $impossible -  AppE2 Conj e1 e2 _ -> do-    (BoolN b1 _) <- evaluate c e1-    (BoolN b2 _) <- evaluate c e2-    return $ BoolN (b1 && b2) BoolT+equExp :: Exp a -> Exp a -> Bool+equExp a b = case compareExp a b of+              EQ -> True+              _  -> False -  AppE2 Disj e1 e2 _ -> do-    (BoolN b1 _) <- evaluate c e1-    (BoolN b2 _) <- evaluate c e2-    return $ BoolN (b1 || b2) BoolT+ltExp :: Exp a -> Exp a -> Bool+ltExp a b = case compareExp a b of+              LT -> True+              _  -> False -  TableE (TableDB (escape -> tName) _) (ListT tType) -> do-      tDesc <- describeTable c tName-      let columnNames = concat $ intersperse " , " $ map (\s -> "\"" ++ s ++ "\"") $ sort $ map fst tDesc-      let query = "SELECT " ++ columnNames ++ " FROM " ++ "\"" ++ tName ++ "\""-      print query-      fmap (sqlToNormWithType tName tType) (quickQuery c query [])-  TableE (TableCSV filename) t -> csvImport filename t-  TableE _ _ -> $impossible+lteExp :: Exp a -> Exp a -> Bool+lteExp a b = case compareExp a b of+               GT -> False+               _  -> True +gteExp :: Exp a -> Exp a -> Bool+gteExp a b = case compareExp a b of+               LT -> False+               _  -> True -snoc :: [a] -> a -> [a]-snoc [] a = [a]-snoc (b : bs) a = b : snoc bs a+gtExp :: Exp a -> Exp a -> Bool+gtExp a b = case compareExp a b of+               GT -> True+               _  -> False  escape :: String -> String escape []                  = [] escape (c : cs) | c == '"' = '\\' : '"' : escape cs escape (c : cs)            =          c : escape cs -evalLam :: Exp -> (Norm -> Exp)-evalLam (LamE f _) n = f (convert n)-evalLam _ _ = $impossible-- -- | Read SQL values into 'Norm' values-sqlToNormWithType :: String             -- ^ Table name, used to generate more-                                        -- informative error messages-                  -> Type-                  -> [[SqlValue]]-                  -> Norm-sqlToNormWithType tName ty = (flip ListN) (ListT ty) . map (sqlValueToNorm ty)-+sqlToExpWithType :: (Reify a)+                 => String  -- ^ Table name, used to generate more informative error messages+                 -> Type a+                 -> [[SqlValue]]+                 -> Exp [a]+sqlToExpWithType tName ty = ListE . map (sqlValueToNorm ty)   where-    sqlValueToNorm :: Type -> [SqlValue] -> Norm-+    sqlValueToNorm :: Type a -> [SqlValue] -> Exp a+    sqlValueToNorm (PairT t1 t2) s = let v1 = sqlValueToNorm t1 $ take (sizeOfType t1) s+                                         v2 = sqlValueToNorm t2 $ drop (sizeOfType t1) s+                                      in PairE v1 v2     -- On a single value, just compare the 'Type' and convert the 'SqlValue' to     -- a Norm value on match     sqlValueToNorm t [s] = if t `typeMatch` s-                      then convert s+                      then convert s t                       else typeError t [s]--    -- On more than one value we need a 'TupleT' type of the exact same length-    sqlValueToNorm t s | length (unfoldType t) == length s =-            let f t' s' = if t' `typeMatch` s'-                             then convert s'-                             else typeError t s-            in foldr1 (\a b -> TupleN a b (TupleT (typeNorm a) (typeNorm b)))-                      (zipWith f (unfoldType t) s)-     -- Everything else will raise an error     sqlValueToNorm t s = typeError t s -    typeError :: Type -> [SqlValue] -> a+    typeError :: Type a -> [SqlValue] -> b     typeError t s = error $         "ferry: Type mismatch on table \"" ++ tName ++ "\":"         ++ "\n\tExpected table type: " ++ show t         ++ "\n\tTable entry: " ++ show s +convert :: SqlValue -> Type a -> Exp a+convert SqlNull         UnitT    = UnitE+convert (SqlInteger i)  IntegerT = IntegerE i+convert (SqlInt32 i)    IntegerT = IntegerE $ fromIntegral i+convert (SqlInt64 i)    IntegerT = IntegerE $ fromIntegral i+convert (SqlWord32 i)   IntegerT = IntegerE $ fromIntegral i+convert (SqlWord64 i)   IntegerT = IntegerE $ fromIntegral i+convert (SqlDouble d)  DoubleT  = DoubleE d+convert (SqlRational d) DoubleT = DoubleE $ fromRational d+convert (SqlInteger d)  DoubleT = DoubleE $ fromIntegral d+convert (SqlInt32 d)    DoubleT = DoubleE $ fromIntegral d+convert (SqlInt64 d)    DoubleT = DoubleE $ fromIntegral d+convert (SqlWord32 d)   DoubleT = DoubleE $ fromIntegral d+convert (SqlWord64 d)   DoubleT = DoubleE $ fromIntegral d+convert (SqlBool b) BoolT       = BoolE b+convert (SqlInteger i) BoolT    = BoolE (i /= 0)+convert (SqlInt32 i)   BoolT    = BoolE (i /= 0)+convert (SqlInt64 i)   BoolT    = BoolE (i /= 0)+convert (SqlWord32 i)  BoolT    = BoolE (i /= 0)+convert (SqlWord64 i)  BoolT    = BoolE (i /= 0) +convert (SqlChar c) CharT       = CharE c+convert (SqlString (c:_)) CharT = CharE c+convert (SqlByteString c) CharT = CharE (head $ T.unpack $ T.decodeUtf8 c)+convert (SqlString t) TextT     = TextE (T.pack t) +convert (SqlByteString s) TextT = TextE (T.decodeUtf8 s)+convert sql                 _   = error $ "Unsupported SqlValue: "  ++ show sql +sizeOfType :: Type a -> Int+sizeOfType UnitT = 1+sizeOfType IntegerT = 1+sizeOfType DoubleT = 1+sizeOfType BoolT = 1+sizeOfType CharT = 1+sizeOfType TextT = 1+sizeOfType (PairT t1 t2) = sizeOfType t1 + sizeOfType t2+sizeOfType _ = error "sizeOfType: Not a record type"+ -- | Check if a 'SqlValue' matches a 'Type'-typeMatch :: Type -> SqlValue -> Bool+typeMatch :: Type a -> SqlValue -> Bool typeMatch t s =     case (t,s) of          (UnitT         , SqlNull)          -> True

@@ -1,33 +0,0 @@-module Database.DSH.JSON (jsonExport, jsonExportHandle, jsonExportStdout) where--import Database.DSH.Data--import Text.JSON--import qualified Data.Text as Text--import qualified System.IO as IO-import System.IO (Handle)--jsonExport :: (QA a) => FilePath -> [a] -> IO ()-jsonExport file as = IO.withFile file IO.WriteMode (\handle -> jsonExportHandle handle as)--jsonExportStdout :: (QA a) => [a] -> IO ()-jsonExportStdout = jsonExportHandle IO.stdout--jsonExportHandle :: (QA a) => Handle -> [a] -> IO ()-jsonExportHandle handle as = IO.hPutStr handle (encode $ go $ toNorm as)-  where go :: Norm -> JSValue-        go e =  case e of-                  UnitN _         -> showJSON "()"-                  BoolN b _       -> showJSON b-                  CharN c _       -> showJSON c-                  IntegerN i _    -> showJSON i-                  DoubleN d _     -> showJSON d-                  TextN t _       -> showJSON (Text.unpack t)-                  TupleN e1 e2 _  -> JSArray $ map go (e1 : deTuple e2)-                  ListN es _      -> JSArray $ map go es--deTuple :: Norm -> [Norm]-deTuple (TupleN e1 e2 _) = e1 : deTuple e2-deTuple n = [n]

@@ -1,585 +1,255 @@-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}--module Database.DSH.TH-    (-      deriveTupleQA-    , generateDeriveTupleQARange-    , deriveTupleTA-    , generateDeriveTupleTARange-    , deriveTupleView-    , generateDeriveTupleViewRange--    , deriveQAForRecord-    , deriveQAForRecord'-    , deriveViewForRecord-    , deriveViewForRecord'-    , deriveTAForRecord-    , deriveTAForRecord'--    , generateDatabaseRecordInstances-    , generateTableRecordInstances-    , generateRecordInstances-    , generateTableDeclarations-    ) where---import Database.DSH.Data-import Database.DSH.Impossible--import Control.Applicative-import Control.Monad-import Data.Convertible-import Data.Char-import Data.List-import Database.HDBC-import Data.Text (Text)--- import Data.Time (UTCTime)-import GHC.Exts--import Language.Haskell.TH hiding (Q, TupleT, tupleT, AppE, VarE, reify, Type, ListT)-import qualified Language.Haskell.TH as TH-import Language.Haskell.TH.Syntax (sequenceQ)----- Create a "a -> b -> ..." type-arrowChainT :: [TypeQ] -> TypeQ-arrowChainT [] = $impossible-arrowChainT as = foldr1 (\a b -> arrowT `appT` a `appT` b) as---- Apply a list of 'TypeQ's to a type constructor-applyChainT :: TypeQ -> [TypeQ] -> TypeQ-applyChainT t ts = foldl' appT t ts---- Apply a list of 'Exp's to a some 'Exp'-applyChainE :: ExpQ -> [ExpQ] -> ExpQ-applyChainE e es = foldl' appE e es--applyChainTupleP :: [PatQ] -> PatQ-applyChainTupleP = foldr1 (\p1 p2 -> conP 'TupleN [p1,p2,wildP])--applyChainTupleE :: Name -> [ExpQ] -> ExpQ-applyChainTupleE n = foldr1 (\e1 e2 -> appE (appE (conE n) e1) e2)-------------------------------------------------------------------------------------- * QA instances------- Original Code--- 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))---   fromNorm (TupleN a b (TupleT _ _)) = (fromNorm a,fromNorm b)---   fromNorm _ = $impossible--deriveTupleQA :: Int -> TH.Q [Dec]-deriveTupleQA l-    | l < 2     = $impossible-    | otherwise = pure `fmap` instanceD qaCxts-                                        qaType-                                        qaDecs--  where-    names@(a:b:rest) = [ mkName $ "a" ++ show i | i <- [1..l] ]--    qaCxts = return [ ClassP ''QA [VarT n] | n <- names ]-    qaType = conT ''QA `appT` applyChainT (TH.tupleT l) (map varT names)-    qaDecs = [ reifyDec-             , fromNormDec-             , toNormDec-             ]--    -- The class functions:--    reifyDec    = funD 'reify [reifyClause]-    reifyClause = clause [ wildP ]-                         ( normalB $ applyChainTupleE 'TupleT [ [| reify (undefined :: $_n) |] | _n <- map varT names ] )-                         []--    fromNormDec    = funD 'fromNorm [fromNormClause, clause [TH.wildP] (normalB [| $impossible |]) [] ]-    fromNormClause = clause [applyChainTupleP (map varP names)]-                            (normalB $ TH.tupE [ [| fromNorm $(varE n) |] | n <- names ])-                            []--    toNormDec    = funD 'toNorm [toNormClause]-    toNormClause = clause [ toNormClausePattern ] (normalB $ fst $ toNormClauseBody $ [ varE n | n <- names ]) []--    toNormClausePattern = tupP [ varP n | n <- names ]--    toNormClauseBody [a1,b1] =-      let t1 = [| TupleT (reify $a1) (reify $b1) |]-          e1 = [| TupleN (toNorm $a1) (toNorm $b1) ($t1) |]-      in  (e1,t1)-    toNormClauseBody (a1 : as1) =-      let (e1,t1) = toNormClauseBody as1-          t2 = [| TupleT (reify $a1) ($t1) |]-          e2 = [| TupleN (toNorm $a1) ($e1) ($t2) |]-      in  (e2,t2)-    toNormClauseBody _ = $impossible----- | Generate all 'QA' instances for tuples within range.-generateDeriveTupleQARange :: Int -> Int -> TH.Q [Dec]-generateDeriveTupleQARange from to =-    concat `fmap` sequenceQ [ deriveTupleQA n | n <- reverse [from..to] ]-------------------------------------------------------------------------------------- * TA instances------- Original code:--- instance (BasicType a, BasicType b, QA a, QA b) => TA (a,b) where--deriveTupleTA :: Int -> TH.Q [Dec]-deriveTupleTA l-    | l < 2     = $impossible-    | otherwise = pure `fmap` instanceD taCxts-                                        taType-                                        taDecs--  where-    names = [ mkName $ "a" ++ show i | i <- [1..l] ]--    taCxts = return $ concat [ [ClassP ''QA [VarT n], ClassP ''BasicType [VarT n]] | n <- names ]-    taType = conT ''TA `appT` applyChainT (TH.tupleT l) (map varT names)-    taDecs = []---- | Generate all 'TA' instances for tuples within range.-generateDeriveTupleTARange :: Int -> Int -> TH.Q [Dec]-generateDeriveTupleTARange from to =-    concat `fmap` sequenceQ [ deriveTupleTA n | n <- reverse [from..to] ]-------------------------------------------------------------------------------------- * View pattern------- Original code:--- instance (QA a,QA b) => View (Q (a,b)) (Q a, Q b) where---   view (Q a) = (Q (AppE (VarE "proj_2_1") a), Q (AppE (VarE "proj_2_1") a))--deriveTupleView :: Int -> TH.Q [Dec]-deriveTupleView l-    | l < 2     = $impossible-    | otherwise = pure `fmap` instanceD viewCxts-                                        viewType-                                        viewDecs--  where-    names = [ mkName $ "a" ++ show i | i <- [1..l] ]-    a = mkName "a"--    first  p = [| AppE1 Fst $p (typeTupleFst (typeExp $p)) |]-    second p = [| AppE1 Snd $p (typeTupleSnd (typeExp $p)) |]--    viewCxts = return [ ClassP ''QA [VarT n] | n <- names ]-    viewType = conT ''View `appT` (conT ''Q `appT` applyChainT (TH.tupleT l) (map varT names))-                           `appT` applyChainT (TH.tupleT l) [ conT ''Q `appT` varT n | n <- names ]--    viewDecs = [ viewDec, fromViewDec ]--    viewDec    = funD 'view [viewClause]-    viewClause = clause [ conP 'Q [varP a] ]-                        ( normalB $ TH.tupE [ if pos == l then [| Q $(f (varE a)) |] else [| Q $(first (f (varE a))) |]-                                            | pos <- [1..l]-                                            , let f = foldr (.) id (replicate (pos - 1) second)-                                            ])-                        []--    fromViewDec = funD 'fromView [fromViewClause]-    fromViewClause = clause [ fromViewClausePattern ]-                            ( normalB [| Q  $(fst $ fromViewClauseBody (map varE names)) |] )-                            []--    fromViewClausePattern = tupP (map (\n -> conP 'Q [varP n]) names)--    fromViewClauseBody [a1,b1] =-      let t1 = [| TupleT (typeExp $a1) (typeExp $b1) |]-          e1 = [| TupleE ($a1) ($b1) ($t1) |]-      in  (e1,t1)-    fromViewClauseBody (a1 : as1) =-      let (e1,t1) = fromViewClauseBody as1-          t2 = [| TupleT (typeExp $a1) ($t1) |]-          e2 = [| TupleE ($a1) ($e1) ($t2) |]-      in  (e2,t2)-    fromViewClauseBody _ = $impossible----- | Generate all 'View' instances for tuples within range.-generateDeriveTupleViewRange :: Int -> Int -> TH.Q [Dec]-generateDeriveTupleViewRange from to =-    concat `fmap` sequenceQ [ deriveTupleView n | n <- reverse [from..to] ]-------------------------------------------------------------------------------------- * Deriving Instances for Records------- | Derive the 'QA' instance for a record definition.-deriveQAForRecord :: TH.Q [Dec] -> TH.Q [Dec]-deriveQAForRecord q = do -  records <- q-  instances <- deriveQAForRecord' q-  return (records ++ instances)---- | Add 'QA' instance to a record without adding the actual data definition.--- Usefull in combination with 'deriveQAForRecord''-deriveQAForRecord' :: TH.Q [Dec] -> TH.Q [Dec]-deriveQAForRecord' q = do-    d <- q-    mapM addInst d-  where-    addInst d@(DataD [] dName [] [RecC rName rVar@(_:_)] _) | dName == rName = do--         let rCxt  = return []-             rType = conT ''QA `appT` conT dName-             rDec  = [ reifyDec-                     , toNormDec-                     , fromNormDec-                     ]--             reifyDec    = funD 'reify [reifyClause]-             reifyClause = clause [ wildP ]-                                  ( normalB $ applyChainTupleE 'TupleT [ [| reify (undefined :: $(return _t)) |] | (_,_,_t) <- rVar] )-                                  []--             names = [ mkName $ "a" ++ show i | i <- [1..length rVar] ]--             fromNormDec    = funD 'fromNorm [fromNormClause, failClause]-             fromNormClause = clause [ applyChainTupleP (map varP names) ]-                                     ( normalB $ (conE dName) `applyChainE` [ [| fromNorm $(varE n) |]-                                                                            | n <- names-                                                                            ]-                                     )-                                     []--             -- Fail with a verbose message where this happened-             failClause = clause [ wildP ]-                                 ( do loc <- location-                                      let pos = show (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc))-                                      normalB [| error $ "ferry: Impossible `fromNorm' at location " ++ pos |]-                                 )-                                 []--             toNormDec    = funD 'toNorm [toNormClause]-             toNormClause = clause [ conP dName (map varP names) ]-                                   ( normalB $ fst $ toNormClauseBody $ [ varE n | n <- names ] )-                                   []-                                   -             toNormClauseBody [a1,b1] =-                let t1 = [| TupleT (reify $a1) (reify $b1) |]-                    e1 = [| TupleN (toNorm $a1) (toNorm $b1) ($t1) |]-                in  (e1,t1)-             toNormClauseBody (a1 : as1) =-                let (e1,t1) = toNormClauseBody as1-                    t2 = [| TupleT (reify $a1) ($t1) |]-                    e2 = [| TupleN (toNorm $a1) ($e1) ($t2) |]-                in  (e2,t2)-             toNormClauseBody _ = $impossible---         instanceD rCxt-                   rType-                   rDec--    addInst _ = error "ferry: Failed to derive 'QA' - Invalid record definition"+module Database.DSH.TH (deriveQA, deriveTupleRangeQA, deriveElim) where --- | Derive the 'View' instance for a record definition. See--- 'deriveQAForRecord' for an example.-deriveViewForRecord :: TH.Q [Dec] -> TH.Q [Dec]-deriveViewForRecord q = do-  recrods <- q-  instances <- deriveViewForRecord' q-  return (recrods ++ instances)+import qualified Database.DSH.Internals  as DSH+import qualified Database.DSH.Impossible as DSH --- | Add 'View' instance to a record without adding the actual data definition.--- Usefull in combination with 'deriveQAForRecord''-deriveViewForRecord' :: TH.Q [Dec] -> TH.Q [Dec]-deriveViewForRecord' q = do-    d <- q-    concat `fmap` mapM addView d-  where-    addView (DataD [] dName [] [RecC rName rVar@(_:_)] dNames) | dName == rName = do+import Language.Haskell.TH -        -- The "View" record definition+-----------------+-- Deriving QA --+----------------- -        let vName  = mkName $ nameBase dName ++ "V"-            vRec   = recC vName [ return (prefixV n, s, makeQ t) | (n,s,t) <- rVar ]+deriveQA :: Name -> Q [Dec]+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 -            prefixV :: Name -> Name-            prefixV n = mkName $ nameBase n ++ "V"+deriveTyConQA :: Name -> [TyVarBndr] -> [Con] -> Q [Dec]+deriveTyConQA name tyVarBndrs cons = do+  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+  toExpDec <- deriveToExp cons+  frExpDec <- deriveFrExp cons+  return [InstanceD context instanceHead [repDec,toExpDec,frExpDec]] -            makeQ :: TH.Type -> TH.Type-            makeQ t = ConT ''Q `AppT` t+deriveTupleRangeQA :: Int -> Int -> Q [Dec]+deriveTupleRangeQA x y = fmap concat (mapM (deriveQA . tupleTypeName) [x .. y]) -            vNames = [] --dNames+-- Derive the Rep type function -        v <- dataD (return [])-                   vName-                   []-                   [vRec]-                   vNames+deriveRep :: Type -> [Con] -> Dec+deriveRep typ cons = TySynInstD ''DSH.Rep [typ] (deriveRepCons cons) -        -- The instance definition+deriveRepCons :: [Con] -> Type+deriveRepCons []  = error errMsgExoticType+deriveRepCons [c] = deriveRepCon c+deriveRepCons cs  = foldr1 (AppT . AppT (ConT ''(,)))+                           (map (AppT (ConT ''[]) . deriveRepCon) cs) -        let rCxt  = return []-            rType = conT ''View `appT` (conT ''Q `appT` conT dName)-                                `appT` (conT vName)-            rDec  = [ viewDec-                    , fromViewDec-                    ]+deriveRepCon :: Con -> Type+deriveRepCon con = case conToTypes con of+  [] -> ConT ''()+  ts -> foldr1 (AppT . AppT (ConT ''(,)))+               (map (AppT (ConT ''DSH.Rep)) ts) -            a = mkName "a"+-- Derive the toExp function of the QA class -            first  p = [| AppE1 Fst $p (typeTupleFst (typeExp $p)) |]-            second p = [| AppE1 Snd $p (typeTupleSnd (typeExp $p)) |]+deriveToExp :: [Con] -> Q Dec+deriveToExp [] = fail errMsgExoticType+deriveToExp cons = do+  clauses <- sequence (zipWith3 deriveToExpClause (repeat (length cons)) [0 .. ] cons)+  return (FunD 'DSH.toExp clauses) -            viewDec    = funD 'view [viewClause]-            viewClause = clause [ conP 'Q [varP a] ]-                                ( normalB $ applyChainE (conE vName)-                                          $ map (appE (conE 'Q))-                                          $ [ if pos == length rVar then (f (varE a)) else (first (f (varE a)))-                                            | pos <- [1 .. length rVar]-                                            , let f = foldr (.) id (replicate (pos - 1) second)-                                            ] )-                                []+deriveToExpClause :: Int -- Total number of constructors+                  -> Int -- Index of the constructor+                  -> Con+                  -> Q Clause+deriveToExpClause 0 _ _ = fail errMsgExoticType+deriveToExpClause 1 _ con = do+  (pat1,names1) <- conToPattern con+  let exp1 = deriveToExpMainExp names1+  let body1 = NormalB exp1+  return (Clause [pat1] body1 [])+deriveToExpClause n i con = do+  (pat1,names1) <- conToPattern con+  let exp1 = deriveToExpMainExp names1+  expList1 <- [| DSH.ListE [ $(return exp1) ] |]+  expEmptyList <- [| DSH.ListE [] |]+  let lists = 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 []) -            -- names for variables used in the `fromView' function-            qs = [ mkName $ "q" ++ show i | i <- [1.. length rVar] ]+deriveToExpMainExp :: [Name] -> Exp+deriveToExpMainExp []     = ConE 'DSH.UnitE+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 -            fromViewDec    = funD 'fromView [fromViewClause] --, failClause]-            fromViewClause = clause [ conP vName [ conP 'Q [varP q1] | q1 <- qs ] ]-                                    ( normalB [| Q  $(fst $ fromViewClauseBody (map varE qs)) |] )-                                    []+deriveFrExp :: [Con] -> Q Dec+deriveFrExp cons = do+  clauses <- sequence (zipWith3 deriveFrExpClause (repeat (length cons)) [0 .. ] cons)+  imp <- DSH.impossible+  let lastClause = Clause [WildP] (NormalB imp) []+  return (FunD 'DSH.frExp (clauses ++ [lastClause])) -            fromViewClauseBody [a1,b1] =-              let t1 = [| TupleT (typeExp $a1) (typeExp $b1) |]-                  e1 = [| TupleE ($a1) ($b1) ($t1) |]-              in  (e1,t1)-            fromViewClauseBody (a1 : as1) =-              let (e1,t1) = fromViewClauseBody as1-                  t2 = [| TupleT (typeExp $a1) ($t1) |]-                  e2 = [| TupleE ($a1) ($e1) ($t2) |]-              in  (e2,t2)-            fromViewClauseBody _ = $impossible+deriveFrExpClause :: Int -- Total number of constructors+                  -> Int -- Index of the constructor+                  -> Con+                  -> Q Clause+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 body1 = NormalB exp1+  return (Clause [pat1] body1 [])+deriveFrExpClause n i con = do+  (_,names1) <- conToPattern con+  let pat1 = deriveFrExpMainPat names1+  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 body1 = NormalB exp1+  return (Clause [pat2] body1 []) +deriveFrExpMainPat :: [Name] -> Pat+deriveFrExpMainPat [] = ConP 'DSH.UnitE []+deriveFrExpMainPat [name] = VarP name+deriveFrExpMainPat names  = foldr1 (\p1 p2 -> ConP 'DSH.PairE [p1,p2]) (map VarP names) +-------------------+-- Deriving Elim --+------------------- -            -- Fail with a verbose message where this happened-            failClause = clause [ wildP ]-                                ( do loc <- location-                                     let pos = show (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc))-                                     normalB [| error $ "ferry: Impossible `fromView' at location " ++ pos |]-                                )-                                []+deriveElim :: Name -> Q [Dec]+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]+    _ -> fail errMsgExoticType -        i <- instanceD rCxt-                       rType-                       rDec+deriveTyConElim :: Name -> [TyVarBndr] -> [Con] -> Q [Dec]+deriveTyConElim name tyVarBndrs cons = do+  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]) :+                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]] -        return [v,i]+-- Derive the Eliminator type function -    addView _ = error "ferry: Failed to derive 'View' - Invalid record definition"+deriveEliminator :: Type -> Type -> [Con] -> Dec+deriveEliminator typ resTy cons = TySynInstD ''DSH.Eliminator [typ,resTy] (deriveEliminatorCons resTy cons) +deriveEliminatorCons :: Type -> [Con] -> Type+deriveEliminatorCons _ []  = error errMsgExoticType+deriveEliminatorCons resTy cs  =+  foldr (AppT . AppT ArrowT)+        (AppT (ConT ''DSH.Q) resTy)+        (map (deriveEliminatorCon resTy) cs) --- | Derive 'TA' instances-deriveTAForRecord :: TH.Q [Dec] -> TH.Q [Dec]-deriveTAForRecord q = do-  records <- q-  instances <- deriveTAForRecord' q-  return (records ++ instances)+deriveEliminatorCon :: Type -> Con -> Type+deriveEliminatorCon resTy con =+  foldr (AppT . AppT ArrowT)+        (AppT (ConT ''DSH.Q) resTy)+        (map (AppT (ConT ''DSH.Q)) (conToTypes con)) -deriveTAForRecord' :: TH.Q [Dec] -> TH.Q [Dec]-deriveTAForRecord' q = q >>= mapM addTA-  where-    addTA (DataD [] dName [] [RecC rName (_:_)] _) | dName == rName =+-- Derive the elim function of the Elim type class -        let taCxt  = return []-            taType = conT ''TA `appT` conT dName-            taDec  = [ ]+deriveElimFun :: [Con] -> Q Dec+deriveElimFun cons = do+  clause1 <- deriveElimFunClause cons+  return (FunD 'DSH.elim [clause1]) -        in instanceD taCxt-                     taType-                     taDec+deriveElimFunClause :: [Con] -> Q Clause+deriveElimFunClause cons = do+  en  <- newName "e"+  fns <- mapM (\ _ -> newName "f") cons+  let fes = map VarE fns+  let pats1 = (ConP 'DSH.Q [VarP en]) : map VarP fns -    addTA _ = error "ferry: Failed to derive 'TA' - Invalid record definition"+  fes2 <- sequence (zipWith deriveElimToLamExp fes (map (length . conToTypes) cons)) +  let e       = VarE en+  let liste   = AppE (ConE 'DSH.ListE) (ListE (deriveElimFunClauseExp e fes2))+  let concate = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Concat)) liste+  let heade   = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Head)) concate+  let qe      = AppE (ConE 'DSH.Q) heade+  return (Clause pats1 (NormalB qe) []) --- | Create lifted record selectors-recordQSelectors :: TH.Q [Dec] -> TH.Q [Dec]-recordQSelectors q = do-  recrods <- q-  selectors <- recordQSelectors' q-  return (recrods ++ selectors)+deriveElimToLamExp :: Exp -> Int -> Q Exp+deriveElimToLamExp f 0 =+  return (AppE (VarE 'const) (AppE (VarE 'DSH.unQ) f))+deriveElimToLamExp f 1 = do+  xn <- newName "x"+  let xe = VarE xn+  let xp = VarP xn+  let qe = AppE (ConE 'DSH.Q) xe+  let fappe = AppE f qe+  let unqe = AppE (VarE 'DSH.unQ) fappe+  return (LamE [xp] unqe)+deriveElimToLamExp f n = do+  xn <- newName "x"+  let xe = VarE xn+  let xp = VarP xn+  let fste = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Fst)) xe+  let snde = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Snd)) xe+  let qe = AppE (ConE 'DSH.Q) fste+  let fappe = AppE f qe+  f' <- deriveElimToLamExp fappe (n - 1)+  return (LamE [xp] (AppE f' snde)) -recordQSelectors' :: TH.Q [Dec] -> TH.Q [Dec]-recordQSelectors' q = q >>= fmap join . mapM addSel+deriveElimFunClauseExp :: Exp -> [Exp] -> [Exp]+deriveElimFunClauseExp _ [] = error errMsgExoticType+deriveElimFunClauseExp e [f] = [AppE (ConE 'DSH.ListE) (ListE [AppE f e])]+deriveElimFunClauseExp e fs = go e fs   where-    addSel :: Dec -> TH.Q [Dec]-    addSel (DataD [] dName [] [RecC rName vst] _) | dName == rName && not (null vst) =--        let namesAndTypes = [ (n, t')-                            | (n, _, t) <- vst-                            , let t' = arrowChainT [ conT ''Q `appT` conT dName-                                                   , conT ''Q `appT` return t-                                                   ]-                            ]--            addFunD (n,t) = let qn = mkName $ nameBase n ++ "Q"-                                vn = mkName $ nameBase n ++ "V"-                             in sequenceQ [ sigD qn t-                                          , funD qn [ clause []-                                                             (normalB [| $(varE vn) . view |])-                                                             []-                                                    ]-                                          ]--         in if null namesAndTypes-               then error "woot?"-               else concat `fmap` mapM addFunD namesAndTypes--    addSel _ = error "ferry: Failed to create record selectors - Invalid record definition"-------------------------------------------------------------------------------------- * Exported enduser functions------- | Generate table declarations for all tables in the database. This function--- should be used in conjunction with generateDatabaseRecordInstances. For--- example, this function generates the following code for the table 'users':------ > users :: Q [User]--- > users = table "users"----generateTableDeclarations :: (IConnection conn)-                             => (IO conn)  -- ^ Database connection-                             -> TH.Q [Dec]-generateTableDeclarations conn = do-  tables <- runIO $ do  c <- conn-                        r <- getTables c-                        disconnect c-                        return r-  declss <- mapM generateTableDeclaration tables-  return (concat declss)--generateTableDeclaration :: String -> TH.Q [Dec]-generateTableDeclaration s = return-  [ TH.SigD (mkName s) (TH.AppT (TH.ConT ''Q) (TH.AppT TH.ListT (TH.ConT (mkName (dataTypeName s)))))-  , TH.FunD (mkName s) [TH.Clause [] (TH.NormalB (TH.AppE (TH.VarE (mkName "table")) (TH.LitE (TH.StringL s)))) []]-  ]---- | Create corresponding Haskell record data types and generate QA and View--- instances for all tables in the database (except for system tables).------ Example usage:------ > $(generateDatabaseRecordInstances myConnection)------ Note that the database information is queried at compile time, not at run time!-generateDatabaseRecordInstances :: (IConnection conn)-                             => (IO conn)  -- ^ Database connection-                             -> TH.Q [Dec]-generateDatabaseRecordInstances conn = do-  tables <- runIO $ do  c <- conn-                        r <- getTables c-                        disconnect c-                        return r-  decss <- mapM (\t -> generateTableRecordInstances conn t (dataTypeName t) [''Show,''Eq]) tables-  return (concat decss)--dataTypeName :: String -> String-dataTypeName []       = []-dataTypeName [c]      = map toUpper (cleanUnderscores [c])-dataTypeName (c : cs) = toUpper c : cleanUnderscores (init cs)--cleanUnderscores :: String -> String-cleanUnderscores []             = []-cleanUnderscores ['_']          = [] -cleanUnderscores ('_' : c : cs) = toUpper c : cleanUnderscores cs-cleanUnderscores (c : cs)       = c : cleanUnderscores cs---- | Lookup a database table, create corresponding Haskell record data types--- and generate QA and View instances------ Example usage:------ > $(generateTableRecordInstances myConnection "users" "User" [''Show,''Eq])------ Note that the table information is queried at compile time, not at run time!-generateTableRecordInstances  :: (IConnection conn)-                              => (IO conn)  -- ^ Database connection-                              -> String     -- ^ Table name-                              -> String     -- ^ Data type name for each row of the table-                              -> [Name]     -- ^ Default deriving instances-                              -> TH.Q [Dec]-generateTableRecordInstances conn t dname dnames = do-    tdesc <- runIO $ do c <- conn-                        r <- describeTable c t-                        disconnect c-                        return r-    generateRecordInstances (createDataType (sortWith fst tdesc))+  go :: Exp -> [Exp] -> [Exp]+  go _ []  = error errMsgExoticType+  go e1 [f1] =+    let paire = AppE (AppE (ConE 'DSH.PairE) (AppE (ConE 'DSH.LamE) f1)) e1+    in  [AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Map)) paire]+  go e1 (f1 : fs1) =+    let fste  = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Fst)) e1+        snde  = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Snd)) e1+        paire = AppE (AppE (ConE 'DSH.PairE) (AppE (ConE 'DSH.LamE) f1)) fste+        mape  = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Map)) paire+    in  mape : go snde fs1 -  where-    createDataType :: [(String, SqlColDesc)] -> TH.Q [Dec]-    createDataType [] = error "ferry: Empty table description"-    createDataType ds = pure `fmap` dataD dCxt-                                          dName-                                          []-                                          [dCon ds]-                                          dNames+-- Helper Functions -    dName     = mkName dname-    dNames    = dnames+conToTypes :: Con -> [Type]+conToTypes (NormalC _name strictTypes) = map snd strictTypes+conToTypes (RecC _name varStrictTypes) = map (\(_,_,t) -> t) varStrictTypes+conToTypes (InfixC st1 _name st2) = [snd st1,snd st2]+conToTypes (ForallC _tyVarBndrs _cxt con) = conToTypes con -    dCxt      = return []-    dCon desc = recC dName (map toVarStrictType desc)+tyVarBndrToName :: TyVarBndr -> Name+tyVarBndrToName (PlainTV name) = name+tyVarBndrToName (KindedTV name _kind) = name -    -- no support for nullable columns yet:-    toVarStrictType (n,SqlColDesc { colType = ty, colNullable = _ }) =-        let t' = case convert ty of-                      IntegerT    -> ConT ''Integer-                      BoolT       -> ConT ''Bool-                      CharT       -> ConT ''Char-                      DoubleT     -> ConT ''Double-                      TextT       -> ConT ''Text-                      _           -> $impossible+conToPattern :: Con -> Q (Pat,[Name])+conToPattern (NormalC name strictTypes) = do+  ns <- mapM (\ _ -> newName "x") strictTypes+  return (ConP name (map VarP ns),ns)+conToPattern (RecC name varStrictTypes) = do+  ns <- mapM (\ _ -> newName "x") varStrictTypes+  return (ConP name (map VarP ns),ns)+conToPattern (InfixC st1 name st2) = do+  ns <- mapM (\ _ -> newName "x") [st1,st2]+  return (ConP name (map VarP ns),ns)+conToPattern (ForallC _tyVarBndr _cxt con) = conToPattern con -        in return (mkName n, NotStrict, t')+conToName :: Con -> Name+conToName (NormalC name _) = name+conToName (RecC name _) = name+conToName (InfixC _ name _) = name+conToName (ForallC _ _ con)	= conToName con +-- Error messages --- | Derive QA and View instances for record definitions------ Example usage:------ > $(generateRecordInstances [d|--- >--- >     data User = User--- >         { userId    :: Int--- >         , userName  :: String--- >         }--- >--- >   |])------ This generates the following record type, which can be used in view patterns------ > data UserV = UserV--- >     { userIdV    :: Q Int--- >     , userNameV  :: Q String--- >     }------ > instance View (Q User) UserV------ and the liftet record selectors:------ > userIdQ      :: Q User -> Q Int--- > userNameQ    :: Q User -> Q String-generateRecordInstances :: TH.Q [Dec] -> TH.Q [Dec]-generateRecordInstances q = do-    d  <- q-    qa <- deriveQAForRecord' q-    v  <- deriveViewForRecord' q-    ta <- deriveTAForRecord' q-    rs <- recordQSelectors' q-    return (d ++ qa ++ v ++ ta ++ rs)+errMsgExoticType :: String+errMsgExoticType =  "Automatic derivation of DSH related type class instances only works for Haskell 98 types."

@@ -1,47 +0,0 @@-module Database.DSH.XHTML (xhtmlExport, xhtmlExportHandle, xhtmlExportStdout) where--import Database.DSH.Data hiding (table)--import Text.XHtml.Strict--import qualified Data.Text as Text--import qualified System.IO as IO-import System.IO (Handle)--xhtmlExport :: (QA a) => FilePath -> [a] -> IO ()-xhtmlExport file as = IO.withFile file IO.WriteMode (\handle -> xhtmlExportHandle handle as)--xhtmlExportStdout :: (QA a) => [a] -> IO ()-xhtmlExportStdout = xhtmlExportHandle IO.stdout--xhtmlExportHandle :: (QA a) => Handle -> [a] -> IO ()-xhtmlExportHandle handle as = IO.hPutStr handle (showHtmlFragment $ go 0 0 $ toNorm as)-  where go :: Integer -> Integer -> Norm -> Html-        go tl rl e =  case e of-                        UnitN _         -> (td $ stringToHtml $ "()")           ! [tdAttr tl rl]-                        BoolN b _       -> (td $ stringToHtml $ show b)         ! [tdAttr tl rl]-                        CharN c _       -> (td $ stringToHtml $ [c])            ! [tdAttr tl rl]-                        IntegerN i _    -> (td $ stringToHtml $ show i)         ! [tdAttr tl rl]-                        DoubleN d _     -> (td $ stringToHtml $ show d)         ! [tdAttr tl rl]-                        TextN t _       -> (td $ stringToHtml $ Text.unpack t)  ! [tdAttr tl rl]-                        TupleN e1 e2 _  -> (concatHtml $ map (go tl rl) (e1 : deTuple e2))-                        ListN es _      -> td $ (table  $ concatHtml-                                                        $ map (\(l1,e1) -> tr (go (tl + 1) l1 e1))-                                                        $ zip [0 ..] es-                                                ) ! [tableAttr]--        tdAttr :: Integer -> Integer -> HtmlAttr-        tdAttr tl rl = case (odd tl,odd rl) of-                         (False,False) -> strAttr "style" "text-align:center; min-width:20px; padding:5px; background-color:#EEE;"-                         (False,True)  -> strAttr "style" "text-align:center; min-width:20px; padding:5px; background-color:#CCC;"-                         (True,False)  -> strAttr "style" "text-align:center; min-width:20px; padding:5px; background-color:#DDD;"-                         (True,True)   -> strAttr "style" "text-align:center; min-width:20px; padding:5px; background-color:#E9E9E9;"--        tableAttr :: HtmlAttr-        tableAttr = strAttr "style" "border-spacing:5px;"---deTuple :: Norm -> [Norm]-deTuple (TupleN e1 e2 _) = e1 : deTuple e2-deTuple n = [n]

@@ -1,5 +1,3 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}- module Main where  import qualified Database.DSH as Q@@ -62,7 +60,7 @@     qc prop_maybe_integer     putStrPad "Either Integer Integer: "     qc prop_either_integer-    +     putStrLn ""     putStrLn "Equality, Boolean Logic and Ordering"     putStrLn "------------------------------------"@@ -102,7 +100,7 @@     qc prop_fst     putStrPad "snd"     qc prop_snd-    +     putStrLn ""     putStrLn "Numerics:"     putStrLn "-----------"@@ -130,7 +128,7 @@     qc prop_negate_integer     putStrPad "negate_double"     qc prop_negate_double-    +     putStrLn ""     putStrLn "Maybe"     putStrLn "-----"@@ -174,7 +172,7 @@     qc prop_rights     putStrPad "partitionEithers"     qc prop_partitionEithers-    +     putStrLn ""     putStrLn "Lists"     putStrLn "-----"@@ -271,8 +269,8 @@     let hs = f2 arg     assert (db == hs) -makePropNotNull ::  (Eq b, Q.QA a, Q.QA b, Show a, Show b)-                    => (Q.Q [a] -> Q.Q b)+makePropNotNull ::  (Eq b, QA a, QA b, Show a, Show b)+                    => (Q [a] -> Q b)                     -> ([a] -> b)                     -> [a]                     -> Property@@ -284,14 +282,14 @@                   -> a                   -> Property makePropDouble f1 f2 arg = monadicIO $ do-    c  <- run $ getConn+    c  <- run getConn     db <- run $ fromQ c $ f1 (Q.toQ arg)     run $ HDBC.disconnect c     let hs = f2 arg     let eps = 1.0E-8 :: Double;         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 :: (QA a, QA b) => (Q a -> Q b -> Q c) -> Q (a,b) -> Q c uncurryQ f = uncurry f . Q.view  -- * Supported Types@@ -347,7 +345,7 @@ prop_neq = makeProp (uncurryQ (Q./=)) (uncurry (/=))  prop_cond :: Bool -> Property-prop_cond = makeProp (\b -> Q.cond b (0 :: Q Integer) 1) (\b -> if b then 0 else 1)+prop_cond = makeProp (\b -> Q.cond b 0 1) (\b -> if b then (0 :: Integer) else 1)  prop_lt :: (Integer, Integer) -> Property prop_lt = makeProp (uncurryQ (Q.<)) (uncurry (<))@@ -419,7 +417,7 @@ 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 :: Either Integer Integer -> Property prop_either =  makeProp (Q.either id id) (either id id)  prop_lefts :: [Either Integer Integer] -> Property@@ -440,7 +438,7 @@ prop_snoc = makeProp (uncurryQ (Q.|>)) (\(a,b) -> a ++ [b])  prop_singleton :: Integer -> Property-prop_singleton = makeProp Q.singleton (\x -> [x])+prop_singleton = makeProp Q.singleton (: [])  prop_head  :: [Integer] -> Property prop_head  = makePropNotNull Q.head head@@ -479,7 +477,7 @@ prop_map = makeProp (Q.map id) (map id)  prop_append :: ([Integer], [Integer]) -> Property-prop_append = makeProp (uncurryQ (Q.><)) (\(a,b) -> a ++ b)+prop_append = makeProp (uncurryQ (Q.++)) (uncurry (++))  prop_filter :: [Integer] -> Property prop_filter = makeProp (Q.filter (const $ Q.toQ True)) (filter $ const True)@@ -494,7 +492,7 @@ prop_null = makeProp Q.null null  prop_length :: [Integer] -> Property-prop_length = makeProp Q.length (fromIntegral . length)+prop_length = makeProp Q.length ((fromIntegral :: Int -> Integer) . length)  prop_reverse :: [Integer] -> Property prop_reverse = makeProp Q.reverse reverse@@ -521,7 +519,7 @@ prop_concat = makeProp Q.concat concat  prop_concatMap :: [Integer] -> Property-prop_concatMap = makeProp (Q.concatMap Q.singleton) (concatMap (\a -> [a]))+prop_concatMap = makeProp (Q.concatMap Q.singleton) (concatMap (: []))  prop_maximum :: [Integer] -> Property prop_maximum = makePropNotNull Q.maximum maximum@@ -549,16 +547,16 @@                      (uncurry   $   break . (==) . fromIntegral)  prop_elem :: (Integer, [Integer]) -> Property-prop_elem = makeProp (uncurryQ $ Q.elem)-                     (uncurry  $   elem)+prop_elem = makeProp (uncurryQ Q.elem)+                     (uncurry    elem)  prop_notElem :: (Integer, [Integer]) -> Property-prop_notElem = makeProp (uncurryQ $ Q.notElem)-                        (uncurry  $   notElem)+prop_notElem = makeProp (uncurryQ Q.notElem)+                        (uncurry    notElem)  prop_lookup :: (Integer, [(Integer,Integer)]) -> Property-prop_lookup = makeProp (uncurryQ $ Q.lookup)-                       (uncurry  $   lookup)+prop_lookup = makeProp (uncurryQ Q.lookup)+                       (uncurry    lookup)  prop_zip :: ([Integer], [Integer]) -> Property prop_zip = makeProp (uncurryQ Q.zip) (uncurry zip)

@@ -1,5 +1,5 @@ all: cabal-		ghc -Wall -O3 --make Main.hs -o Main+		ghc -Wall -O3 -fno-warn-orphans --make Main.hs -o Main 		./Main  hpc: cabal@@ -10,7 +10,7 @@ 		hpc markup Main  cabal: clean-		cd ..; cabal clean; cabal install; cd tests;+		cd ..; cabal install; cd tests;  clean: 		rm -rf tmp .hpc *.html *.tix *.o *.hi Main