DSH (empty) → 0.4
raw patch · 18 files changed
+3639/−0 lines, 18 filesdep +FerryCoredep +HDBCdep +HaXmlsetup-changed
Dependencies added: FerryCore, HDBC, HaXml, Pathfinder, array, base, bytestring, containers, convertible, csv, haskell-src-exts, mtl, syb, syntax-trees, template-haskell, text
Files
- DSH.cabal +86/−0
- LICENSE +30/−0
- Setup.hs +3/−0
- examples/Example1.hs +73/−0
- examples/Example1_data.sql +78/−0
- examples/Example2.hs +37/−0
- src/Database/DSH.hs +96/−0
- src/Database/DSH/CSV.hs +53/−0
- src/Database/DSH/Combinators.hs +309/−0
- src/Database/DSH/Compile.hs +235/−0
- src/Database/DSH/Compiler.hs +358/−0
- src/Database/DSH/Data.hs +453/−0
- src/Database/DSH/Impossible.hs +10/−0
- src/Database/DSH/Interpreter.hs +404/−0
- src/Database/DSH/QQ.hs +330/−0
- src/Database/DSH/TH.hs +528/−0
- tests/Main.hs +540/−0
- tests/Makefile +16/−0
+ DSH.cabal view
@@ -0,0 +1,86 @@+Name: DSH+Version: 0.4+Synopsis: Database Supported Haskell+Description:+ This is a Haskell library for database-supported program execution. Using+ this library a relational database management system (RDBMS) can be used as+ a coprocessor for the Haskell programming language, especially for those+ program fragments that carry out data-intensive and data-parallel+ computation.+ .+ Database executable program fragments can be written using the list+ comprehension notation (with modest syntax changes due to quasiquoting) and+ list processing combinators from the Haskell list prelude. Note that rather+ than embedding a relational language into Haskell, we turn idiomatic Haskell+ programs into SQL queries.+ .+ DSH faithfully represents list order and nesting, and compiles the list+ processing combinators into relational queries. The implementation avoids+ unnecessary data transfer and context switching between the database+ coprocessor and the Haskell runtime by ensuring that the number of generated+ relational queries is only determined by the program fragment's type and not+ by the database size.+ .+ DSH can be used to allow existing Haskell programs to operate on large scale+ data (e.g., larger than the available heap) or query existing database+ resident data with Haskell.+ .+ Note that this package is flagged experimental and therefore not suited for+ production use. This is a proof of concept implementation only. To learn+ more about DSH, our paper entitled as "Haskell boards the Ferry:+ Database-supported program execution for Haskell" [1] is a recommended+ reading. The package includes a couple of examples that demonstrate how to+ use DSH.+ .+ 1. <http://www-db.informatik.uni-tuebingen.de/files/publications/ferryhaskell.pdf>++License: BSD3+License-file: LICENSE+Author: George Giorgidze, Tom Schreiber, Nils Schweinsberg and Jeroen Weijers+Maintainer: giorgidze@gmail.com, jeroen.weijers@uni-tuebingen.de+Stability: Experimental+Category: Database+Build-type: Simple++Extra-source-files: examples/Example1.hs+ examples/Example1_data.sql+ examples/Example2.hs+ tests/Main.hs+ tests/Makefile++Cabal-version: >= 1.2++Library+ Build-depends: base >= 4.2 && < 5,+ containers >= 0.3,+ array >= 0.3,+ syb >= 0.1,+ mtl >= 2.0.1,+ bytestring >= 0.9.1.7,+ text >= 0.10,+ HDBC >= 2.2,+ convertible >= 1.0,+ template-haskell >= 2.4,+ haskell-src-exts >= 1.9,+ syntax-trees >= 0.1.2,+ HaXml >= 1.20,+ csv >= 0.1.2,+ Pathfinder >= 0.4,+ FerryCore >= 0.4++ Hs-Source-Dirs: src++ GHC-Options: -O3 -Wall++ Exposed-modules: Database.DSH+ Database.DSH.Interpreter+ Database.DSH.Compiler++ Other-modules: Database.DSH.QQ+ Database.DSH.TH+ Database.DSH.Data+ Database.DSH.Combinators+ Database.DSH.CSV+ Database.DSH.Impossible+ Database.DSH.Compile+ Paths_DSH
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright George Giorgidze, Tom Schreiber, Nils Schweinsberg and Jeroen Weijers 2010++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the names of the authors nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ examples/Example1.hs view
@@ -0,0 +1,73 @@+-- This module is part of the DSH-Compiler package and serves as an example on+-- howto use DSH. It is accompanied by a file ExampleData.sql that contains+-- SQL instructions to setup the database that is used by this example.++-- Quasiquoting has to be enabled to support the list comprehension syntax+{-# LANGUAGE QuasiQuotes #-}++module Main where++-- We hide everything in the prelude as DSH exposes a lot of same combinators.+-- In general we recommend to import the module Database.DSH module qualified.+-- The Database.DSH.Compiler module has to be imported seperately this module+-- contains the machinery necessary to execute the query. This module is part+-- of the DSH-Compiler package, the other module (Database.DSH) is part of+-- DSH-Core. We provide the modules in separate packages so that different+-- backend can be made and used for the DSH query facility.++import Prelude () +import Database.DSH+import Database.DSH.Compiler++-- For our example we use postgresql, any database will do as long it can be+-- approached through HDBC.+import Database.HDBC.PostgreSQL++-- Setup the connection string. In order for this to work you must provide a+-- username, password, host and database name.+getConn :: IO Connection+getConn = connectPostgreSQL "user = 'postgres' password = 'haskell98' host = 'localhost' dbname = 'ferry'"++-- DSH uses Text instead of string for strings, as a string will be treated as a+-- list of characters.+type Facility = Text+type Cat = Text+type Feature = Text+type Meaning = Text++-- Declare the database tables, note that you *MUST* declare all columns+-- present in a table. And all columns must be in the same order as they are+-- declared in the database. During compilation the types of the columns will+-- be checked against the provided haskell types. When possible the types of+-- columns will be inferred, if they cannot be fully inferred the user has to+-- provide explicit types!++facilities :: Q [(Cat, Facility)]+facilities = table "facilities"+ +features :: Q [(Facility, Feature)]+features = table "features"+ +meanings :: Q [(Feature, Meaning)]+meanings = table "meanings"+ +-- Helper function for the query.+-- Despite the different braces for the comprehension the comprehension body+-- works as normal+descrFacility :: Q Facility -> Q [Meaning]+descrFacility f = [$qc| mean | (feat,mean) <- meanings, + (fac,feat1) <- features, + feat == feat1 && fac == f|]++-- Main query, use the helper function+query :: Q [(Text , [Text])] +query = [$qc| tuple (the cat, nub $ concatMap descrFacility fac) + | (cat, fac) <- facilities, then group by cat |]+++-- Execute the query+main :: IO ()+main = do+ conn <- getConn -- Get a connection+ result <- fromQ conn query -- Execute the query using fromQ+ print result
+ examples/Example1_data.sql view
@@ -0,0 +1,78 @@+-- DROP TABLE "facilities" CASCADE;+-- DROP TABLE "features" CASCADE;+-- DROP TABLE "meanings" CASCADE ;++CREATE TABLE "facilities" (+ facility text NOT NULL,+ categorie text NOT NULL+);++CREATE TABLE "features" (+ facility text NOT NULL,+ feature text NOT NULL+);++CREATE TABLE "meanings" (+ feature text NOT NULL,+ meaning text NOT NULL+);++INSERT INTO "facilities" (facility, categorie) VALUES ('SQL', 'QLA');+INSERT INTO "facilities" (facility, categorie) VALUES ('ODBC', 'API');+INSERT INTO "facilities" (facility, categorie) VALUES ('LINQ', 'LIN');+INSERT INTO "facilities" (facility, categorie) VALUES ('Links', 'LIN');+INSERT INTO "facilities" (facility, categorie) VALUES ('Rails', 'ORM');+INSERT INTO "facilities" (facility, categorie) VALUES ('Ferry', 'LIB');+INSERT INTO "facilities" (facility, categorie) VALUES ('Kleisli', 'QLA');+INSERT INTO "facilities" (facility, categorie) VALUES ('ADO.NET', 'ORM');+INSERT INTO "facilities" (facility, categorie) VALUES ('HaskellDB', 'LIB');++INSERT INTO "features" (facility, feature) VALUES ('Kleisli', 'nest');+INSERT INTO "features" (facility, feature) VALUES ('Kleisli', 'comp');+INSERT INTO "features" (facility, feature) VALUES ('Kleisli', 'type');+INSERT INTO "features" (facility, feature) VALUES ('Links', 'comp');+INSERT INTO "features" (facility, feature) VALUES ('Links', 'type');+INSERT INTO "features" (facility, feature) VALUES ('Links', 'SQL');+INSERT INTO "features" (facility, feature) VALUES ('LINQ', 'nest');+INSERT INTO "features" (facility, feature) VALUES ('LINQ', 'comp');+INSERT INTO "features" (facility, feature) VALUES ('LINQ', 'type');+INSERT INTO "features" (facility, feature) VALUES ('HaskellDB', 'comp');+INSERT INTO "features" (facility, feature) VALUES ('HaskellDB', 'type');+INSERT INTO "features" (facility, feature) VALUES ('HaskellDB', 'SQL');+INSERT INTO "features" (facility, feature) VALUES ('SQL', 'aval');+INSERT INTO "features" (facility, feature) VALUES ('SQL', 'type');+INSERT INTO "features" (facility, feature) VALUES ('SQL', 'SQL');+INSERT INTO "features" (facility, feature) VALUES ('Rails', 'nest');+INSERT INTO "features" (facility, feature) VALUES ('Rails', 'maps');+INSERT INTO "features" (facility, feature) VALUES ('ADO.NET', 'maps');+INSERT INTO "features" (facility, feature) VALUES ('ADO.NET', 'comp');+INSERT INTO "features" (facility, feature) VALUES ('ADO.NET', 'type');+INSERT INTO "features" (facility, feature) VALUES ('Ferry', 'list');+INSERT INTO "features" (facility, feature) VALUES ('Ferry', 'nest');+INSERT INTO "features" (facility, feature) VALUES ('Ferry', 'comp');+INSERT INTO "features" (facility, feature) VALUES ('Ferry', 'aval');+INSERT INTO "features" (facility, feature) VALUES ('Ferry', 'type');+INSERT INTO "features" (facility, feature) VALUES ('Ferry', 'SQL');++INSERT INTO "meanings" (feature, meaning) VALUES ('maps', 'admits user-defined object mappings');+INSERT INTO "meanings" (feature, meaning) VALUES ('list', 'respects list order');+INSERT INTO "meanings" (feature, meaning) VALUES ('nest', 'supports data nesting');+INSERT INTO "meanings" (feature, meaning) VALUES ('comp', 'has compositional syntax and semantics');+INSERT INTO "meanings" (feature, meaning) VALUES ('aval', 'avoids query avalanches');+INSERT INTO "meanings" (feature, meaning) VALUES ('type', 'is statically type-checked');+INSERT INTO "meanings" (feature, meaning) VALUES ('SQL', 'guarantees translation to SQL');++ALTER TABLE ONLY "facilities"+ ADD CONSTRAINT "facilities_pkey" PRIMARY KEY (facility);++ALTER TABLE ONLY "features"+ ADD CONSTRAINT "features_pkey" PRIMARY KEY (facility, feature);++ALTER TABLE ONLY "meanings"+ ADD CONSTRAINT "meanings_pkey" PRIMARY KEY (feature);++ALTER TABLE ONLY "features"+ ADD CONSTRAINT "foreign facility" FOREIGN KEY (facility) REFERENCES "facilities"(facility);++ALTER TABLE ONLY "features"+ ADD CONSTRAINT "foreign feature" FOREIGN KEY (feature) REFERENCES "meanings"(feature);
+ examples/Example2.hs view
@@ -0,0 +1,37 @@+-- This example was taken from the paper called "Comprehensive Comprehensions"+-- by Phil Wadler and Simon Peyton Jones++{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}++module Main where++import Prelude ()+import Database.DSH+import Database.DSH.Compiler++import Database.HDBC.PostgreSQL++employees :: Q [(Text, Text, Integer)]+employees = toQ [+ ("Simon", "MS", 80)+ , ("Erik", "MS", 90)+ , ("Phil", "Ed", 40)+ , ("Gordon", "Ed", 45)+ , ("Paul", "Yale", 60)+ ]++query :: Q [(Text, Integer)]+query = [$qc| tuple (the dept, sum salary)+ | (name, dept, salary) <- employees+ , then group by dept+ , then sortWith by (sum salary)+ , then take 5 |]++getConn :: IO Connection+getConn = connectPostgreSQL "user = 'postgres' password = 'haskell98' host = 'localhost' dbname = 'ferry'"++main :: IO ()+main = do+ conn <- getConn+ result <- fromQ conn query+ print result
+ src/Database/DSH.hs view
@@ -0,0 +1,96 @@+-- |+-- This module is intended to be imported @qualified@, to avoid name clashes+-- with "Prelude" functions. For example:+--+-- > import qualified Database.DSH as Q+-- > import Database.DSH (Q)+--+-- Alternatively you can hide "Prelude" and import this module like this:+--+-- > import Prelude ()+-- > import Database.DSH+--+-- In this case you still get Prelude definitions that are not provided+-- by Database.DSH.++module Database.DSH+ (+ module Database.DSH.Combinators++ -- * Data Types+ , Q+ , Time++ -- * Type Classes+ , QA+ , TA, table, tableDB, tableCSV, tableWithKeys, BasicType+ , View, view, fromView, tuple, record++ -- * Quasiquoter+ , qc++ -- * Template Haskell: Creating Table Representations+ , generateRecords+ , generateInstances++ , module Data.Text+ , module Database.HDBC+ , module Prelude+ )+ where++import Database.DSH.Data (Q, QA, TA, Time, table, tableDB, tableCSV, tableWithKeys, BasicType, View, view, fromView, tuple, record)+import Database.DSH.QQ (qc)+import Database.DSH.TH (generateRecords, generateInstances)++import Database.DSH.Combinators++import Data.Text (Text)+import Database.HDBC++import Prelude hiding (+ not+ , (&&)+ , (||)+ , (==)+ , (/=)+ , (<)+ , (<=)+ , (>=)+ , (>)+ , min+ , max+ , head+ , tail+ , take+ , drop+ , map+ , filter+ , last+ , init+ , null+ , length+ , (!!)+ , reverse+ , and+ , or+ , any+ , all+ , sum+ , concat+ , concatMap+ , maximum+ , minimum+ , splitAt+ , takeWhile+ , dropWhile+ , span+ , break+ , elem+ , notElem+ , zip+ , zipWith+ , unzip+ , fst+ , snd+ )
+ src/Database/DSH/CSV.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.CSV (csvImport) where++import Database.DSH.Data+import Database.DSH.Impossible++import Text.CSV+import qualified Data.Text as Text++csvImport :: FilePath -> Type -> IO Norm+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))++ where++ csvError :: String -> a+ csvError s = error ("Error in '" ++ filepath ++ "': " ++ s)+ + recordType :: Type -> Type+ recordType (ListT rType) = rType+ recordType _ = $impossible+ + csvRecordToNorm :: Type -> [String] -> Norm+ csvRecordToNorm t rs = case (t,rs) of+ (UnitT , [] ) -> UnitN UnitT+ (_ , [] ) -> er+ (t1 , [bs] ) -> csvFieldToNorm t1 bs+ (TupleT t1 t2, bs : bss) -> TupleN (csvFieldToNorm t1 bs) (csvRecordToNorm t2 bss) (TupleT t1 t2)+ (_ , _ ) -> er+ where+ er = csvError ("When converting record '" ++ show rs ++ "' to a value of type '" ++ show t ++ "'")+ ++ csvFieldToNorm :: Type -> String -> Norm+ csvFieldToNorm t s = case t of+ UnitT -> UnitN UnitT+ BoolT -> BoolN (read s) BoolT+ CharT -> CharN (head s) CharT+ IntegerT -> IntegerN (read s) IntegerT+ DoubleT -> DoubleN (read s) DoubleT+ TextT -> TextN (Text.pack s) TextT+ TimeT -> er+ TupleT _ _ -> er+ ListT _ -> er+ ArrowT _ _ -> er+ where+ er = csvError ("When converting CSV field'" ++ s ++ "' to a value of type '" ++ show t ++ "'")
+ src/Database/DSH/Combinators.hs view
@@ -0,0 +1,309 @@+{-# 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, undefined, error, ($))++-- * Unit++unit :: Q ()+unit = Q (UnitE $ reify (undefined :: ()))++-- * Boolean logic++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++cond :: (QA a) => Q a -> Q a -> Q Bool -> Q a+cond a b c = c ? (a,b)++bool :: (QA a) => Q a -> Q a -> Q Bool -> Q a+bool = cond++(?) :: forall a. (QA a) => Q Bool -> (Q a,Q a) -> Q a+(?) (Q c) (Q a,Q b) = Q (AppE3 Cond c a b $ reify (undefined :: a))++-- * 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])))++-- * 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))+++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 8)+$(generateDeriveTupleTARange 3 8)+$(generateDeriveTupleViewRange 3 8)+++-- * 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++searching lists:++> elem+> notElem++Infinit lists:++> iterate+> repeat+> cycle++String functions:++> lines+> words+> unlines+> unwords++Searching lists:++> lookup++Zipping and unzipping lists:++> zip3+> zipWith3+> unzip3++-}
+ src/Database/DSH/Compile.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, ParallelListComp #-}+module Database.DSH.Compile where++import Database.DSH.Data+import Database.DSH.Impossible (impossible)++import Database.Pathfinder++import qualified Data.Array as A+import qualified Data.List as L+import Data.Maybe (fromJust, isNothing, isJust)+import Data.List (sortBy)+import Control.Monad.Reader+import Control.Exception (evaluate)++import qualified Text.XML.HaXml as X+import Text.XML.HaXml (Content(..), AttValue(..), tag, deep, children, xmlParse, Document(..))++import Database.HDBC+import Data.Convertible++-- | Wrapper type with phantom type for algebraic plan+-- The type variable represents the type of the result of the plan+newtype AlgebraXML a = Algebra String++-- | Wrapper type with phantom type for SQL plan+-- The type variable represents the type of the result of the plan+newtype SQLXML a = SQL String+ deriving Show++-- | Type representing a query bundle, the type variable represents the type+-- of the result of the query bundle. A bundle consists of pair of numbered queries.+-- Each query consists of the query itself, a schema explaining its types.+-- If the query is a nested value in the result of another query the optional attribute+-- represents (queryID, columnID). The queryId refers to the number of the query in the bundle+-- the columnID refers +newtype QueryBundle a = Bundle [(Int, (String, SchemaInfo, Maybe (Int, Int)))]++-- | Description of a table. The field iterN contains the name of the iter column+-- the items field contains a list of item column names and their position within the result.+data SchemaInfo = SchemaInfo {iterN :: String, items :: [(String, Int)]}++-- | Description of result data of a query. The field iterR contains the column number of+-- the iter column. resCols contains a for all items columns their column number in the result.+data ResultInfo = ResultInfo {iterR :: Int, resCols :: [(String, Int)]}+ deriving Show++-- | 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 c p = do+ sql@(SQL _s) <- algToSQL p+ runSQL c $ extractSQL sql++algToAlg :: AlgebraXML a -> IO (AlgebraXML a)+algToAlg (Algebra s) = do+ r <- compileFerryOpt s OutputXml Nothing+ case r of+ (Right sql) -> return $ Algebra sql+ (Left err) -> error $ "Pathfinder compilation for input: \n"+ ++ s ++ "\n failed with error: \n"+ ++ err++-- | Translate an algebraic plan into SQL code using Pathfinder+algToSQL :: AlgebraXML a -> IO (SQLXML a)+algToSQL (Algebra s) = do+ r <- compileFerryOpt s OutputSql Nothing+ case r of+ (Right sql) -> return $ SQL sql+ (Left err) -> error $ "Pathfinder compilation for input: \n"+ ++ s ++ "\n failed with error: \n"+ ++ err++-- | Extract the SQL queries from the XML structure generated by pathfinder+extractSQL :: SQLXML a -> QueryBundle a+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 "id" attrs of+ Just x -> x+ Nothing -> $impossible+ rId = fmap attrToInt $ lookup "idref" attrs+ cId = fmap attrToInt $ lookup "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+ in (qId, (query, schema, ref))+ extractQuery _ = $impossible+ attrToInt :: AttValue -> Int+ attrToInt (AttValue [(Left i)]) = read i+ attrToInt _ = $impossible+ attrToString :: AttValue -> String+ 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+ in SchemaInfo iterName cols+ process :: Content i -> (String, Maybe Int)+ process (CElem (X.Elem _ attrs _) _) = let name = fromJust $ fmap attrToString $ lookup "name" attrs+ pos = fmap attrToInt $ lookup "position" attrs+ in (name, pos)+ 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 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++-- | 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 +-- the number of a nested query. The second component is a tuple consisting of query number associated+-- with a pair of the raw result data partitioned by iter, and a description of this result data.+type QueryR = Reader ([((Int, Int), Int)] ,[(Int, ([(Int, [[SqlValue]])], ResultInfo))])++-- | Retrieve the data asociated with query i.+getResults :: Int -> QueryR [(Int, [[SqlValue]])]+getResults i = do+ env <- ask+ return $ case lookup i $ snd env of+ Just x -> fst x+ Nothing -> $impossible++-- | Get the position of item i of query q+getColResPos :: Int -> Int -> QueryR Int+getColResPos q i = do+ env <- ask+ return $ case lookup q $ snd env of+ Just (_, ResultInfo _ x) -> snd (x !! i)+ Nothing -> $impossible++-- | Get the id of the query that is nested in column c of query q.+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++-- | 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+ v <- getResults i+ mapM (\(it, vals) -> do+ v1 <- processResults' i 0 vals t1+ return (it, ListN v1 ty)) v+processResults i t = do+ v <- getResults i+ mapM (\(it, vals) -> do+ v1 <- processResults' i 0 vals t+ return (it, head v1)) v++-- | 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+ v1s <- processResults' q c vals t1+ v2s <- processResults' q (c + 1) vals t2+ return $ [TupleN v1 v2 t | v1 <- v1s | v2 <- v2s]+processResults' q c vals t@(ListT _) = do+ nestQ <- findQuery (q, c)+ list <- processResults nestQ t+ let maxI = if null list+ then 1+ else fst $ L.maximumBy (\x y -> fst x `compare` fst y) list+ let lA = (A.accumArray ($impossible) Nothing (1,maxI) []) A.// map (\(x,y) -> (x, Just y)) list+ i <- getColResPos q c+ return $ map (\val -> case lA A.! ((convert $ val !! i)::Int) of+ Just x -> x+ Nothing -> ListN [] t) vals+processResults' _ _ _ (TimeT) = error "Results processing for time has not been implemented."+processResults' _ _ _ (ArrowT _ _) = $impossible -- The result cannot be a function+processResults' q c vals t = do+ i <- getColResPos q c+ return $ map (\val -> convert $ (val !! i, t)) vals+++-- | Partition by iter column+-- The first argument is the position of the iter column.+-- The second argument the raw data+-- It returns a list of pairs (iterVal, rawdata within iter) +partByIter :: Int -> [[SqlValue]] -> [(Int, [[SqlValue]])]+partByIter n (v:vs) = let i = getIter n v+ (vi, vr) = span (\v' -> i == getIter n v') vs+ in (i, v:vi) : partByIter n vr+ where+ getIter :: Int -> [SqlValue] -> Int+ getIter n' vals = ((fromSql (vals !! n'))::Int)+partByIter _ [] = []+++-- | Execute the given query plan bundle, over the provided connection.+-- It returns the raw data for each query along with a description on how to reconstruct +-- ordinary haskell data+runQuery :: IConnection conn => conn -> (Int, (String, SchemaInfo, Maybe (Int, Int))) -> IO (Int, ([(Int, [[SqlValue]])], ResultInfo, Maybe (Int, Int)))+runQuery c (qId, (query, schema, ref)) = do+ sth <- prepare c query+ _ <- execute sth []+ res <- dshFetchAllRowsStrict sth+ resDescr <- describeResult sth+ let ri = schemeToResult schema resDescr+ let res' = partByIter (iterR ri) res + return (qId, (res', ri, ref))++dshFetchAllRowsStrict :: Statement -> IO [[SqlValue]]+dshFetchAllRowsStrict stmt = go []+ where+ go :: [[SqlValue]] -> IO [[SqlValue]]+ go acc = do mRow <- fetchRow stmt+ case mRow of+ Nothing -> return (reverse acc)+ Just row -> do mapM_ evaluate row+ go (row : acc)++-- | 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+ 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, _)) (qm, rm) = (qm, (q, (r, ri)):rm)
+ src/Database/DSH/Compiler.hs view
@@ -0,0 +1,358 @@+{- | DSH compiler module exposes the function fromQ that can be used to+execute DSH programs on a database. It transform the DSH program into+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, debugPlanOpt, debugSQL) where++import Database.DSH.Data as D+import Database.DSH.Impossible (impossible)+import Database.DSH.CSV (csvImport)++import Database.DSH.Compile as C++import Database.Ferry.SyntaxTyped as F+import Database.Ferry.Compiler++import qualified Data.Map as M+import Data.Char+import Database.HDBC+import Data.Convertible++import Control.Monad.State+import Control.Applicative++import Data.Text (unpack)++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++-- | Provide a fresh identifier name during compilation+freshVar :: N conn Int+freshVar = do+ (c, i, env) <- get+ put (c, i + 1, env)+ return i++-- | Get from the state the connection to the database +getConnection :: IConnection conn => N conn conn+getConnection = do+ (c, _, _) <- get+ return c++-- | 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 t = do+ (c, i, env) <- get+ case M.lookup t env of+ Nothing -> do+ inf <- lift $ getTableInfo c t+ put (c, i, M.insert t inf env)+ return inf + Just v -> return v++-- | Turn a given integer into a variable beginning with prefix "__fv_" +prefixVar :: Int -> String+prefixVar = ((++) "__fv_") . show+ +-- | Execute the transformation computation. During+-- compilation table information can be retrieved from+-- the database, therefor the result is wrapped in the IO+-- Monad. +runN :: IConnection conn => conn -> N conn a -> IO a+runN c = liftM fst . flip runStateT (c, 1, M.empty)+ +-- * Convert DB queries into Haskell values++-- | Similar to fromQ, gets as an extra argument a boolean determining whether +-- debugging is switched on+fromQ :: (QA a, IConnection conn) => conn -> Q a -> IO a+fromQ c a = evaluate c a >>= (return . fromNorm)+++-- | Convert the query in an unoptimized algebraic plan.+debugPlan :: (QA a, IConnection conn) => conn -> Q a -> IO String+debugPlan = doCompile++-- | Convert the query in an optimized algebraic plan+debugPlanOpt :: (QA a, IConnection conn) => conn -> Q a -> IO String+debugPlanOpt q c = do+ p <- doCompile q c+ (C.Algebra r) <- algToAlg ((C.Algebra p)::AlgebraXML a)+ return r+ +-- | 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++-- | 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)+ 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++-- | 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 (TimeE _ _) = error "transformation of time values has not been implemented yet."+transformE (TupleE e1 e2 ty) = do+ c1 <- transformE e1+ c2 <- transformE e2+ return $ Rec ([] :=> transformTy ty) [RecElem (typeOf c1) "1" c1, RecElem (typeOf c2) "2" c2] +transformE (ListE es ty) = let qt = ([] :=> transformTy ty) + in foldr (\h t -> F.Cons qt h t) (Nil qt) <$> mapM transformE es+transformE (AppE f a _) = transformE $ f a +transformE (AppE1 f1 e1 ty) = do+ let tr = transformTy ty+ e1' <- transformArg e1+ 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+ 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+ 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)+-- 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+ 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 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 table' = Table ([] :=> tTy) n cols keys+ let pattern = [prefixVar fv]+ let nameType = map (\(Column name t) -> (name, t)) cols + let body = foldr (\(nr, t) b -> + let (_ :=> bt) = typeOf b+ in Rec ([] :=> FRec [(RLabel "1", t), (RLabel "2", bt)]) [RecElem ([] :=> t) "1" (F.Elem ([] :=> t) varB nr), RecElem ([] :=> bt) "2" b])+ ((\(nr,t) -> F.Elem ([] :=> t) varB nr) $ last nameType)+ (init nameType)+ let ([] :=> rt) = typeOf body+ let lambda = ParAbstr ([] :=> FRec ts .-> rt) pattern body+ let expr = App ([] :=> FList rt) (App ([] :=> (FList $ FRec ts) .-> FList rt) + (Var ([] :=> (FRec ts .-> rt) .-> (FList $ FRec ts) .-> FList rt) "map") + lambda)+ (ParExpr (typeOf table') table') + 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++-- | 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 ++-- | 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 (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 _ = $impossible++-- Determine the size of a flat type+sizeOfTy :: Type -> Int+sizeOfTy (TupleT _ t2) = 1 + sizeOfTy t2+sizeOfTy _ = 1 ++-- | Transform an arbitrary DSH-type into a ferry core type +transformTy :: Type -> FType+transformTy UnitT = int+transformTy BoolT = bool+transformTy CharT = string+transformTy TextT = string+transformTy IntegerT = int+transformTy DoubleT = float+transformTy TimeT = error "transformation of time types has not been implemented yet."+transformTy (TupleT t1 t2) = FRec [(RLabel "1", transformTy t1), (RLabel "2", transformTy t2)]+transformTy (ListT t1) = FList $ transformTy t1+transformTy (ArrowT t1 t2) = (transformTy t1) .-> (transformTy t2)++-- | 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++-- | 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 Conj = Op "&&"+transformOp Disj = Op "||"+transformOp _ = $impossible++-- | Transform a DSH-primitive-function (f) with an instantiated typed into a FerryCore+-- expression+transformF :: (Show f) => f -> FType -> CoreExpr+transformF f t = Var ([] :=> t) $ (\txt -> case txt of+ (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 c n = do+ info <- describeTable c n+ return $ toTableDescr info+ + where+ 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]+ t -> error $ "You can't store this kind of data in a table... " ++ show t ++ " " ++ show n
+ src/Database/DSH/Data.hs view
@@ -0,0 +1,453 @@+{-# 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 Data.Time+import GHC.Exts++type Time = Integer+type Real = Double++data Exp =+ UnitE Type+ | BoolE Bool Type+ | CharE Char Type+ | IntegerE Integer Type+ | DoubleE Double Type+ | TextE Text Type+ | TimeE Time Type+ | TupleE Exp Exp Type+ | ListE [Exp] Type+ | LamE (Exp -> Exp) Type+ | AppE (Exp -> Exp) Exp Type+ | AppE1 Fun1 Exp Type+ | AppE2 Fun2 Exp Exp Type+ | AppE3 Fun3 Exp Exp Exp Type+ | TableE Table Type+ | VarE Int Type+ deriving (Data, Typeable)++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+ | TimeN Time Type+ | TupleN Norm Norm Type+ | ListN [Norm] Type+ deriving (Eq, Ord, Show, Data, Typeable)++data Type =+ UnitT+ | BoolT+ | CharT+ | IntegerT+ | DoubleT+ | TextT+ | TimeT+ | 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+ TimeE _ t -> t+ TupleE _ _ t -> t+ ListE _ t -> t+ LamE _ t -> t+ AppE _ _ 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++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 Time where+-- reify _ = TimeT+-- toNorm t = TimeN t TimeT+-- fromNorm (TimeN t TimeT) = t+-- fromNorm _ = $impossible+++instance (QA a,QA b) => QA (a,b) where+ reify _ = TupleT (reify (undefined :: a)) (reify (undefined :: b))+ toNorm (a,b) = TupleN (toNorm a) (toNorm b) (reify (a,b))+ 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++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+-- instance BasicType Time 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, Show and Num Instances for Databse Queries++instance Show (Q a) where+ show _ = "Query"++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 View (Q Time) (Q Time) where+-- view = id+-- fromView = id++instance (QA a,QA b) => View (Q (a,b)) (Q a, Q b) where+ view (Q a) = (Q (AppE1 Fst a (reify (undefined :: a))), Q (AppE1 Snd a (reify (undefined :: b))))+ fromView ((Q e1),(Q e2)) = Q (TupleE e1 e2 (reify (undefined :: (a, b))))++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+ TimeN u t -> TimeE u t+ IntegerN i t -> IntegerE i t+ DoubleN d t -> DoubleE d t+ TupleN n1 n2 t -> TupleE (convert n1) (convert n2) t+ 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+ TimeT -> Right SqlTimestampT+ 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+ SqlBigIntT -> Right IntegerT+ SqlDoubleT -> Right DoubleT+ SqlRealT -> Right DoubleT+ SqlBitT -> Right BoolT+ SqlCharT -> Right CharT+ SqlVarCharT -> Right TextT+ SqlDateT -> Right TimeT+ SqlTimestampT -> Right TimeT+ _ -> convError "Unsupported `SqlTypeId'" n+++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+ -- SqlLocalTime t -> Right $ TimeN (localTimeToUTC utc t) TimeT+ -- SqlLocalDate d -> Right $ TimeN (UTCTime d 0) TimeT+ _ -> convError "Unsupported `SqlValue'" sql++instance Convertible (SqlValue, Type) Norm where+ 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++ (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++ _ -> error (show sql) -- $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+ TimeN _t _ -> convError "Cannot convert `Norm' to `SqlValue'" n -- Right $ SqlUTCTime t+ ListN _ _ -> convError "Cannot convert `Norm' to `SqlValue'" n+ TupleN _ _ _ -> convError "Cannot convert `Norm' to `SqlValue'" n+ + +instance IsString (Q Text) where+ fromString s = Q (TextE (T.pack s) TextT)
+ src/Database/DSH/Impossible.hs view
@@ -0,0 +1,10 @@+module Database.DSH.Impossible (impossible) where++import qualified Language.Haskell.TH as TH++impossible :: TH.ExpQ+impossible = do+ 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)))
+ src/Database/DSH/Interpreter.hs view
@@ -0,0 +1,404 @@+{-# 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 Data.Convertible+import Database.HDBC+import GHC.Exts+import Data.List++-- * Convert DB queries into Haskell values+fromQ :: (QA a, IConnection conn) => conn -> Q a -> IO a+fromQ c (Q a) = evaluate c a >>= (return . fromNorm)++evaluate :: IConnection conn+ => conn -- ^ The HDBC connection+ -> Exp+ -> IO Norm+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)+ TimeE u t -> return (TimeN u t)++ VarE _ _ -> $impossible+ LamE _ _ -> $impossible++ AppE f1 e1 _ -> evaluate c (f1 e1)++ TupleE e1 e2 t -> do+ e3 <- evaluate c e1+ e4 <- evaluate c e2+ 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+ 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++ AppE1 Not e1 _ -> do+ (BoolN b1 _) <- evaluate c e1+ return $ BoolN (not b1) BoolT++ AppE2 Conj e1 e2 _ -> do+ (BoolN b1 _) <- evaluate c e1+ (BoolN b2 _) <- evaluate c e2+ return $ BoolN (b1 && b2) BoolT++ AppE2 Disj e1 e2 _ -> do+ (BoolN b1 _) <- evaluate c e1+ (BoolN b2 _) <- evaluate c e2+ return $ BoolN (b1 || b2) BoolT++ 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+++snoc :: [a] -> a -> [a]+snoc [] a = [a]+snoc (b : bs) a = b : snoc bs a++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)++ where+ sqlValueToNorm :: Type -> [SqlValue] -> Norm++ -- 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+ 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 t s = error $+ "ferry: Type mismatch on table \"" ++ tName ++ "\":"+ ++ "\n\tExpected table type: " ++ show t+ ++ "\n\tTable entry: " ++ show s+++-- | Check if a 'SqlValue' matches a 'Type'+typeMatch :: Type -> SqlValue -> Bool+typeMatch t s =+ case (t,s) of+ (UnitT , SqlNull) -> True+ (IntegerT , SqlInteger _) -> True+ (DoubleT , SqlDouble _) -> True+ (BoolT , SqlBool _) -> True+ (CharT , SqlChar _) -> True+ (TextT , SqlString _) -> True+ (TextT , SqlByteString _) -> True+ (TimeT , SqlLocalTime _) -> True+ (TimeT , SqlLocalDate _) -> True+ _ -> False
+ src/Database/DSH/QQ.hs view
@@ -0,0 +1,330 @@+{-# LANGUAGE TemplateHaskell, ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}++module Database.DSH.QQ (qc) where++import Paths_DSH as DSH+import Database.DSH.Impossible++import Language.Haskell.SyntaxTrees.ExtsToTH (translateExtsToTH)++import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH+import qualified Language.Haskell.TH.Quote as TH++import Language.Haskell.Exts++import Control.Monad+import Control.Monad.State+import Control.Applicative++import Data.Generics++import qualified Data.List as L+import Data.Version (showVersion)++combinatorMod :: ModuleName+combinatorMod = ModuleName "database.DSH.Combinators"++dataMod :: ModuleName+dataMod = ModuleName "database.DSH.Data"++{-+N monad, version of the state monad that can provide fresh variable names.+-}+newtype N a = N (State Int a)++unwrapN :: N a -> State Int a+unwrapN (N s) = s++instance Functor N where+ fmap f a = N $ fmap f $ unwrapN a++instance Monad N where+ s >>= m = N (unwrapN s >>= unwrapN . m)+ return = N . return++instance Applicative N where+ pure = return+ (<*>) = ap++freshVar :: N String+freshVar = N $ do+ i <- get+ put (i + 1)+ return $ "ferryFreshNamesV" ++ show i++runN :: N a -> a+runN = fst . (flip runState 1) . unwrapN+++quoteListCompr :: String -> TH.ExpQ+quoteListCompr = transform . parseCompr++transform :: Exp -> TH.ExpQ+transform e = case translateExtsToTH . runN $ translateListCompr e of+ Left err -> error $ show err+ Right e1 -> return $ globalQuals e1++parseCompr :: String -> Exp+parseCompr = fromParseResult . exprParser++ferryParseMode :: ParseMode+ferryParseMode = defaultParseMode {+ extensions = [TransformListComp, ViewPatterns]+ , fixities = fixities defaultParseMode ++ infix_ 0 ["?"] ++ infixr_ 5 ["><", "<|", "|>"]+ }++exprParser :: String -> ParseResult Exp+exprParser = parseExpWithMode ferryParseMode . expand++expand :: String -> String+expand e = '[':(e ++ "]")++ferryHaskell :: TH.QuasiQuoter+ferryHaskell = TH.QuasiQuoter {TH.quoteExp = quoteListCompr}++qc :: TH.QuasiQuoter+qc = ferryHaskell++fp :: TH.QuasiQuoter+fp = TH.QuasiQuoter {TH.quoteExp = (return . TH.LitE . TH.StringL . show . parseCompr)}++rw :: TH.QuasiQuoter+rw = TH.QuasiQuoter {TH.quoteExp = (return . TH.LitE . TH.StringL . show . translateExtsToTH . runN . translateListCompr . parseCompr)}++translateListCompr :: Exp -> N Exp+translateListCompr (ListComp e q) = do+ let pat = variablesFromLst $ reverse q+ lambda <- makeLambda pat (SrcLoc "" 0 0) e+ (mapF lambda) <$> normaliseQuals q+translateListCompr (ParComp e qs) = do+ let pat = variablesFromLsts qs+ lambda <- makeLambda pat (SrcLoc "" 0 0) e+ (mapF lambda) <$> normParallelCompr qs+translateListCompr l = error $ "Expr not supported by Ferry: " ++ show l++-- Transforming qualifiers++++normParallelCompr :: [[QualStmt]] -> N Exp+normParallelCompr [] = $impossible+normParallelCompr [x] = normaliseQuals x+normParallelCompr (x:xs) = zipF <$> (normaliseQuals x) <*> (normParallelCompr xs)+++normaliseQuals :: [QualStmt] -> N Exp+normaliseQuals = normaliseQuals' . reverse++normaliseQuals' :: [QualStmt] -> N Exp+normaliseQuals' ((ThenTrans e):ps) = paren . (app e) <$> normaliseQuals' ps+normaliseQuals' ((ThenBy ef ek):ps) = do+ let pv = variablesFromLst ps+ ks <- makeLambda pv (SrcLoc "" 0 0) ek+ app (app ef ks) <$> normaliseQuals' ps+normaliseQuals' ((GroupBy e):ps) = normaliseQuals' ((GroupByUsing e groupWithF):ps)+normaliseQuals' ((GroupByUsing e f):ps) = do+ let pVar = variablesFromLst ps+ lambda <- makeLambda pVar (SrcLoc "" 0 0) e+ unzipped <- unzipB pVar+ (\x -> mapF unzipped (app (app f lambda) x)) <$> normaliseQuals' ps+normaliseQuals' ((GroupUsing e):ps) = let pVar = variablesFromLst ps+ in mapF <$> unzipB pVar <*> (app e <$> normaliseQuals' ps)+normaliseQuals' [q] = normaliseQual q+normaliseQuals' [] = pure $ consF unit nilF+normaliseQuals' (q:ps) = do+ qn <- normaliseQual q+ let qv = variablesFrom q+ pn <- normaliseQuals' ps+ let pv = variablesFromLst ps+ combine pn pv qn qv++normaliseQual :: QualStmt -> N Exp+normaliseQual (QualStmt (Generator _ _ e)) = pure $ e+normaliseQual (QualStmt (Qualifier e)) = pure $ boolF (consF unit nilF) nilF e+normaliseQual (QualStmt (LetStmt (BDecls bi@[PatBind _ p _ _ _]))) = pure $ flip consF nilF $ letE bi $ patToExp p+normaliseQual _ = $impossible++combine :: Exp -> Pat -> Exp -> Pat -> N Exp+combine p pv q qv = do+ qLambda <- makeLambda qv (SrcLoc "" 0 0) $ fromViewF (tuple [patToExp qv, patToExp pv])+ pLambda <- makeLambda pv (SrcLoc "" 0 0) $ mapF qLambda q+ pure $ concatF (mapF pLambda p)++unzipB :: Pat -> N Exp+unzipB PWildCard = paren <$> makeLambda PWildCard (SrcLoc "" 0 0) unit+unzipB p@(PVar x) = paren <$> makeLambda p (SrcLoc "" 0 0) (var x)+unzipB (PTuple [xp, yp]) = do+ e <- freshVar+ let ePat = patV e+ let eArg = varV e+ xUnfold <- unzipB xp+ yUnfold <- unzipB yp+ (<$>) paren $ makeLambda ePat (SrcLoc "" 0 0) $+ fromViewF $ tuple [app xUnfold $ paren $ mapF fstV eArg, app yUnfold $ mapF sndV eArg]+unzipB (PTuple ps) = do+ let pl = length ps+ e <- freshVar+ let ePat = patV e+ let eArg = varV e+ ps' <- mapM (\_ -> freshVar) ps+ ups <- mapM unzipB ps+ views <- mapM (viewN ps') [0..(pl-1)]++ (<$>) paren $ makeLambda ePat (SrcLoc "" 0 0) $+ fromViewF $ tuple [app unf $ paren $ mapF proj eArg | (unf, proj) <- zip ups views]++unzipB _ = $impossible++viewN :: [String] -> Int -> N Exp+viewN ps i = let e = varV $ ps !! i+ pat = PTuple $ map patV ps+ in makeLambda pat (SrcLoc "" 0 0) e++patV :: String -> Pat+patV = PVar . name++varV :: String -> Exp+varV = var . name++-- Building and converting patterns+++variablesFromLsts :: [[QualStmt]] -> Pat+variablesFromLsts [] = $impossible+variablesFromLsts [x] = variablesFromLst $ reverse x+variablesFromLsts (x:xs) = PTuple [variablesFromLst $ reverse x, variablesFromLsts xs]++variablesFromLst :: [QualStmt] -> Pat+variablesFromLst ((ThenTrans _):xs) = variablesFromLst xs+variablesFromLst ((ThenBy _ _):xs) = variablesFromLst xs+variablesFromLst ((GroupBy _):xs) = variablesFromLst xs+variablesFromLst ((GroupUsing _):xs) = variablesFromLst xs+variablesFromLst ((GroupByUsing _ _):xs) = variablesFromLst xs+variablesFromLst [x] = variablesFrom x+variablesFromLst (x:xs) = PTuple [variablesFrom x, variablesFromLst xs]+variablesFromLst [] = PWildCard++variablesFrom :: QualStmt -> Pat+variablesFrom (QualStmt (Generator _ p _)) = p+variablesFrom (QualStmt (Qualifier _)) = PWildCard+variablesFrom (QualStmt (LetStmt (BDecls [PatBind _ p _ _ _]))) = p+variablesFrom (QualStmt e) = error $ "Not supported yet: " ++ show e+variablesFrom _ = $impossible++makeLambda :: Pat -> SrcLoc -> Exp -> N Exp+makeLambda p s b = do+ (p', e') <- mkViewPat p b+ pure $ Lambda s [p'] e'+++mkViewPat :: Pat -> Exp -> N (Pat, Exp)+mkViewPat p@(PVar _) e = return $ (p, e)+mkViewPat PWildCard e = return $ (PWildCard, e)+mkViewPat (PTuple ps) e = do+ x <- freshVar+ (pr, e') <- foldl viewTup (pure $ ([], e)) ps+ let px = PVar $ name x+ let vx = var $ name x+ let er = caseE (app viewV vx) [alt (SrcLoc "" 0 0) (PTuple $ reverse pr) e']+ return (px, er)++mkViewPat (PList ps) e = do+ x <- freshVar+ let px = PVar $ name x+ let vx = var $ name x+ let er = caseE (app viewV vx) [alt (SrcLoc "" 0 0) (PList ps) e]+ return (px, er)+mkViewPat (PParen p) e = do+ (p', e') <- mkViewPat p e+ return (PParen p', e')+mkViewPat p e = do+ x <- freshVar+ let px = PVar $ name x+ let vx = var $ name x+ let er = caseE (app viewV vx) [alt (SrcLoc "" 0 0) p e]+ return (px, er)++viewTup :: N ([Pat], Exp) -> Pat -> N ([Pat], Exp)+viewTup r p = do+ (rp, re) <- r+ (p', e') <- mkViewPat p re+ return (p':rp, e')++viewV :: Exp+viewV = var $ name $ "view"++patToExp :: Pat -> Exp+patToExp (PVar x) = var x+patToExp (PTuple [x, y]) = fromViewF $ tuple [patToExp x, patToExp y]+patToExp (PApp (Special UnitCon) []) = unit+patToExp PWildCard = unit+patToExp p = error $ "Pattern not suppoted by ferry: " ++ show p++-- Ferry Combinators++fstV :: Exp+fstV = qvar combinatorMod $ name "fst"++sndV :: Exp+sndV = qvar combinatorMod $ name "snd"++mapV :: Exp+mapV = qvar combinatorMod $ name "map"++mapF :: Exp -> Exp -> Exp+mapF f l = flip app l $ app mapV f++unit :: Exp+unit = qvar combinatorMod $ name "unit"++consF :: Exp -> Exp -> Exp+consF hd tl = flip app tl $ app consV hd++nilF :: Exp+nilF = nilV++nilV :: Exp+nilV = qvar combinatorMod $ name "nil"++consV :: Exp+consV = qvar combinatorMod $ name "cons"++fromViewV :: Exp+fromViewV = qvar dataMod $ name "fromView"++fromViewF :: Exp -> Exp+fromViewF e1 = app fromViewV e1++concatF :: Exp -> Exp+concatF = app concatV++concatV :: Exp+concatV = qvar combinatorMod $ name "concat"++boolF :: Exp -> Exp -> Exp -> Exp+boolF t e c = app (app ( app (qvar combinatorMod $ name "bool") t) e) c++groupWithF :: Exp+groupWithF = qvar combinatorMod $ name "groupWith"++zipV :: Exp+zipV = qvar combinatorMod $ name "zip"++zipF :: Exp -> Exp -> Exp+zipF x y = app (app zipV x) y+++-- Generate proper global names from pseudo qualified variables+toNameG :: TH.Name -> TH.Name+toNameG n@(TH.Name (TH.occString -> occN) (TH.NameQ (TH.modString -> m))) =+ if "database" `L.isPrefixOf` m+ then let pkgN = "DSH-" ++ showVersion (DSH.version)+ modN = "Database" ++ (drop 8 m)+ in TH.mkNameG_v pkgN modN occN+ else n+toNameG n = n++globalQuals :: TH.Exp -> TH.Exp+globalQuals = everywhere (mkT toNameG)
+ src/Database/DSH/TH.hs view
@@ -0,0 +1,528 @@+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}++module Database.DSH.TH+ (+ deriveTupleQA+ , generateDeriveTupleQARange+ , deriveTupleTA+ , generateDeriveTupleTARange+ , deriveTupleView+ , generateDeriveTupleViewRange++ , deriveQAForRecord+ , deriveQAForRecord'+ , deriveViewForRecord+ , deriveViewForRecord'+ , deriveTAForRecord+ , deriveTAForRecord'++ , generateRecords+ , generateInstances+ ) where+++import Database.DSH.Data+import Database.DSH.Impossible++import Control.Applicative+import Control.Monad+import Data.Convertible+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"++-- | 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)++-- | 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++ -- The "View" record definition++ let vName = mkName $ nameBase dName ++ "V"+ vRec = recC vName [ return (prefixV n, s, makeQ t) | (n,s,t) <- rVar ]++ prefixV :: Name -> Name+ prefixV n = mkName $ nameBase n ++ "V"++ makeQ :: TH.Type -> TH.Type+ makeQ t = ConT ''Q `AppT` t++ vNames = [] --dNames++ v <- dataD (return [])+ vName+ []+ [vRec]+ vNames++ -- The instance definition++ let rCxt = return []+ rType = conT ''View `appT` (conT ''Q `appT` conT dName)+ `appT` (conT vName)+ rDec = [ viewDec+ , fromViewDec+ ]++ a = mkName "a"++ first p = [| AppE1 Fst $p (typeTupleFst (typeExp $p)) |]+ second p = [| AppE1 Snd $p (typeTupleSnd (typeExp $p)) |]++ 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)+ ] )+ []++ -- names for variables used in the `fromView' function+ qs = [ mkName $ "q" ++ show i | i <- [1.. length rVar] ]++ fromViewDec = funD 'fromView [fromViewClause] --, failClause]+ fromViewClause = clause [ conP vName [ conP 'Q [varP q1] | q1 <- qs ] ]+ ( normalB [| Q $(fst $ fromViewClauseBody (map varE qs)) |] )+ []++ 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++++ -- 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 |]+ )+ []++ i <- instanceD rCxt+ rType+ rDec++ return [v,i]++ addView _ = error "ferry: Failed to derive 'View' - Invalid record definition"+++-- | Derive 'TA' instances+deriveTAForRecord :: TH.Q [Dec] -> TH.Q [Dec]+deriveTAForRecord q = do+ records <- q+ instances <- deriveTAForRecord' q+ return (records ++ instances)++deriveTAForRecord' :: TH.Q [Dec] -> TH.Q [Dec]+deriveTAForRecord' q = q >>= mapM addTA+ where+ addTA (DataD [] dName [] [RecC rName (_:_)] _) | dName == rName =++ let taCxt = return []+ taType = conT ''TA `appT` conT dName+ taDec = [ ]++ in instanceD taCxt+ taType+ taDec++ addTA _ = error "ferry: Failed to derive 'TA' - Invalid record definition"+++-- | Create lifted record selectors+recordQSelectors :: TH.Q [Dec] -> TH.Q [Dec]+recordQSelectors q = do+ recrods <- q+ selectors <- recordQSelectors' q+ return (recrods ++ selectors)++recordQSelectors' :: TH.Q [Dec] -> TH.Q [Dec]+recordQSelectors' q = q >>= fmap join . mapM addSel+ 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+--++-- | Lookup a database table, create corresponding Haskell record data types+-- and generate QA and View instances+--+-- Example usage:+--+-- > $(generateRecords myConnection "users" "User" [''Show,''Eq])+--+-- Note that the da is created at compile time, not at run time!+generateRecords :: (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]+generateRecords conn t dname dnames = do+ tdesc <- runIO $ do+ c <- conn+ describeTable c t+ generateInstances (createDataType (sortWith fst tdesc))++ where+ createDataType :: [(String, SqlColDesc)] -> TH.Q [Dec]+ createDataType [] = error "ferry: Empty table description"+ createDataType ds = pure `fmap` dataD dCxt+ dName+ []+ [dCon ds]+ dNames++ dName = mkName dname+ dNames = dnames++ dCxt = return []+ dCon desc = recC dName (map toVarStrictType desc)++ -- 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+ TimeT -> ConT ''Time+ _ -> $impossible++ in return (mkName n, NotStrict, t')+++-- | Derive QA and View instances for record definitions+--+-- Example usage:+--+-- > $(generateInstances [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+generateInstances :: TH.Q [Dec] -> TH.Q [Dec]+generateInstances q = do+ d <- q+ qa <- deriveQAForRecord' q+ v <- deriveViewForRecord' q+ ta <- deriveTAForRecord' q+ rs <- recordQSelectors' q+ return $ d ++ qa ++ v ++ ta ++ rs
+ tests/Main.hs view
@@ -0,0 +1,540 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import qualified Database.DSH as Q+import Database.DSH (Q, QA)++-- import Database.DSH.Interpreter (fromQ)+import Database.DSH.Compiler (fromQ)++import qualified Database.HDBC as HDBC+import Database.HDBC.PostgreSQL++import Test.QuickCheck+import Test.QuickCheck.Monadic++import Data.List+import GHC.Exts++import Data.Text (Text)+import qualified Data.Text as Text++import Data.Char++instance Arbitrary Text where+ arbitrary = fmap Text.pack arbitrary++getConn :: IO Connection+getConn = connectPostgreSQL "user = 'postgres' password = 'haskell98' host = 'localhost' dbname = 'ferry'"++qc:: Testable prop => prop -> IO ()+qc = quickCheckWith stdArgs{maxSuccess = 20, maxSize = 10}++main :: IO ()+main = do+ putStrLn "Running DSH prelude tests"+ putStrLn "-------------------------"+ putStr "unit: "+ qc prop_unit+ putStr "Bool: "+ qc prop_bool+ putStr "Char: "+ qc prop_char+ putStr "Text: "+ qc prop_text+ putStr "Integer: "+ qc prop_integer+ putStr "Double: "+ qc prop_double++ putStrLn ""+ putStrLn "Equality & Ordering"+ putStrLn "-------------------------"+ putStr "&&: "+ qc prop_infix_and+ putStr "||: "+ qc prop_infix_or+ putStr "not: "+ qc prop_not+ putStr "eq: "+ qc prop_eq_int+ putStr "neq: "+ qc prop_neq_int+ putStr "lt: "+ qc prop_lt+ putStr "lte: "+ qc prop_lte+ putStr "gt: "+ qc prop_gt+ putStr "gte: "+ qc prop_gte+ putStr "min_integer: "+ qc prop_min_integer+ putStr "min_double: "+ qc prop_min_double+ putStr "max_integer: "+ qc prop_max_integer+ putStr "max_double: "+ qc prop_max_double++ putStrLn ""+ putStrLn "Tuple projection functions"+ putStrLn "-------------------------"+ putStr "fst: "+ qc prop_fst+ putStr "snd: "+ qc prop_snd++ putStrLn ""+ putStrLn "Conditionals:"+ putStrLn "-------------------------"+ putStr "cond: "+ qc prop_cond++ putStrLn ""+ putStrLn "Numerical operations:"+ putStrLn "-------------------------"+ putStr "add_integer: "+ qc prop_add_integer+ putStr "add_double: "+ qc prop_add_double+ putStr "mul_integer: "+ qc prop_mul_integer+ putStr "mul_double: "+ qc prop_mul_double+ putStr "div_double: "+ qc prop_div_double+ putStr "integer_to_double: "+ qc prop_integer_to_double + putStr "abs_integer: "+ qc prop_abs_integer+ putStr "abs_double: "+ qc prop_abs_double+ putStr "signum_integer: "+ qc prop_signum_integer+ putStr "signum_double: "+ qc prop_signum_double+ putStr "negate_integer: "+ qc prop_negate_integer+ putStr "negate_double: "+ qc prop_negate_double++ putStrLn ""+ putStrLn "Lists"+ putStrLn "-------------------------"+ putStr "head: "+ qc prop_head+ putStr "tail: "+ qc prop_tail+ putStr "cons: "+ qc prop_cons+ putStr "snoc: "+ qc prop_snoc+ putStr "take: "+ qc prop_take+ putStr "drop: "+ qc prop_drop+ putStr "map_id: "+ qc prop_map_id+ putStr "filter_True: "+ qc prop_filter_True+ putStr "the: "+ qc prop_the+ putStr "last: "+ qc prop_last+ putStr "init: "+ qc prop_init+ putStr "null: "+ qc prop_null+ putStr "length: "+ qc prop_length+ putStr "index: "+ qc prop_index+ putStr "reverse: "+ qc prop_reverse+ putStr "append: "+ qc prop_append+ putStr "groupWith_id: "+ qc prop_groupWith_id+ putStr "sortWith_id: "+ qc prop_sortWith_id++ putStrLn ""+ putStrLn "Special folds"+ putStrLn "-------------------------"+ putStr "and: "+ qc prop_and+ putStr "or: "+ qc prop_or+ putStr "any_zero: "+ qc prop_any_zero+ putStr "all_zero: "+ qc prop_all_zero+ putStr "sum_integer: "+ qc prop_sum_integer+ putStr "sum_double: "+ qc prop_sum_double+ putStr "concat: "+ qc prop_concat+ putStr "concatMap: "+ qc prop_concatMap+ putStr "maximum: "+ qc prop_maximum+ putStr "minimum: "+ qc prop_minimum++ putStrLn ""+ putStrLn "Sublists"+ putStrLn "-------------------------"+ putStr "splitAt: "+ qc prop_splitAt+ putStr "takeWhile: "+ qc prop_takeWhile+ putStr "dropWhile: "+ qc prop_dropWhile+ putStr "span: "+ qc prop_span+ putStr "break: "+ qc prop_break++ putStrLn ""+ putStrLn "Zipping and unzipping lists"+ putStrLn "-------------------------"+ putStr "zip: "+ qc prop_zip+ putStr "zipWith_plus: "+ qc prop_zipWith_plus+ putStr "unzip: "+ qc prop_unzip++ putStrLn ""+ putStrLn "Set operations"+ putStrLn "-------------------------"+ putStr "nub: "+ qc prop_nub+++runTest :: (Eq b, QA a, QA b, Show a, Show b)+ => (Q a -> Q b)+ -> (a -> b)+ -> a+ -> Property+runTest q f arg = monadicIO $ do+ c <- run $ getConn+ db <- run $ fromQ c (q (Q.toQ arg))+ run $ HDBC.disconnect c+ let hs = f arg+ assert (db == hs)++testNotNull :: (Eq b, Q.QA a, Q.QA b, Show a, Show b)+ => (Q.Q [a] -> Q.Q b)+ -> ([a] -> b)+ -> [a]+ -> Property+testNotNull q f arg = not (null arg) ==> runTest q f arg++runTestDouble :: (QA a, Show a)+ => (Q a -> Q Double)+ -> (a -> Double)+ -> a+ -> Property+runTestDouble q f arg = monadicIO $ do+ c <- run $ getConn+ db <- run $ fromQ c (q (Q.toQ arg))+ run $ HDBC.disconnect c+ let hs = f arg+ let eps = 1.0E-8 :: Double; + assert (abs(db - hs) < eps)++++uncurry_Q :: (Q.QA a, Q.QA b) => (Q.Q a -> Q.Q b -> Q.Q c) -> Q.Q (a,b) -> Q.Q c+uncurry_Q q = uncurry q . Q.view++prop_unit :: () -> Property+prop_unit = runTest id id++prop_bool :: Bool -> Property+prop_bool = runTest id id++prop_integer :: Integer -> Property+prop_integer = runTest id id++prop_double :: Double -> Property+prop_double = runTestDouble id id++isValidXmlChar :: Char -> Bool+isValidXmlChar c =+ '\x0009' <= c && c <= '\x000A'+ || '\x000D' <= c && c <= '\x000D'+ || '\x0020' <= c && c <= '\xD7FF'+ || '\xE000' <= c && c <= '\xFFFD'+ || '\x10000'<= c && c <= '\x10FFFF'++prop_char :: Char -> Property+prop_char c = isPrint c ==> runTest id id c++prop_text :: Text -> Property+prop_text t = Text.all isPrint t ==> runTest id id t++++--------------------------------------------------------------------------------+-- Equality & Ordering++prop_infix_and :: (Bool,Bool) -> Property+prop_infix_and = runTest (uncurry_Q (Q.&&)) (uncurry (&&))++prop_infix_or :: (Bool,Bool) -> Property+prop_infix_or = runTest (uncurry_Q (Q.||)) (uncurry (||))++prop_not :: Bool -> Property+prop_not = runTest Q.not not++prop_eq :: (Eq a, Q.QA a, Show a) => (a,a) -> Property+prop_eq = runTest (\q -> Q.fst q Q.== Q.snd q) (\(a,b) -> a == b)++prop_eq_int :: (Integer,Integer) -> Property+prop_eq_int = prop_eq++prop_neq :: (Eq a, Q.QA a, Show a) => (a,a) -> Property+prop_neq = runTest (uncurry_Q (Q./=)) (\(a,b) -> a /= b)++prop_neq_int :: (Integer,Integer) -> Property+prop_neq_int = prop_eq++prop_lt :: (Integer, Integer) -> Property+prop_lt = runTest (uncurry_Q (Q.<)) (uncurry (<))++prop_lte :: (Integer, Integer) -> Property+prop_lte = runTest (uncurry_Q (Q.<=)) (uncurry (<=))++prop_gt :: (Integer, Integer) -> Property+prop_gt = runTest (uncurry_Q (Q.>)) (uncurry (>))++prop_gte :: (Integer, Integer) -> Property+prop_gte = runTest (uncurry_Q (Q.>=)) (uncurry (>=))++prop_min_integer :: (Integer,Integer) -> Property+prop_min_integer = runTest (uncurry_Q Q.min) (uncurry min)++prop_max_integer :: (Integer,Integer) -> Property+prop_max_integer = runTest (uncurry_Q Q.max) (uncurry max)++prop_min_double :: (Double,Double) -> Property+prop_min_double = runTestDouble (uncurry_Q Q.min) (uncurry min)++prop_max_double :: (Double,Double) -> Property+prop_max_double = runTestDouble (uncurry_Q Q.max) (uncurry max)++--------------------------------------------------------------------------------+-- Lists++prop_cons :: (Integer, [Integer]) -> Property+prop_cons = runTest (uncurry_Q (Q.<|)) (uncurry (:))++prop_snoc :: ([Integer], Integer) -> Property+prop_snoc = runTest (uncurry_Q (Q.|>)) (\(a,b) -> a ++ [b])++prop_singleton :: Integer -> Property+prop_singleton = runTest Q.singleton (\x -> [x])+++-- head, tail, last, init, the and index may fail:++prop_head :: [Integer] -> Property+prop_head = testNotNull Q.head head++prop_tail :: [Integer] -> Property+prop_tail = testNotNull Q.tail tail++prop_last :: [Integer] -> Property+prop_last = testNotNull Q.last last++prop_init :: [Integer] -> Property+prop_init = testNotNull Q.init init++prop_the :: [Integer] -> Property+prop_the l =+ allEqual l+ ==> runTest Q.the the l+ where+ allEqual [] = False+ allEqual (x:xs) = all (x ==) xs++prop_index :: ([Integer], Integer) -> Property+prop_index (l, i) =+ i > 0 && i < fromIntegral (length l)+ ==> runTest (uncurry_Q (Q.!!))+ (\(a,b) -> a !! fromIntegral b)+ (l, i)+++prop_take :: (Integer, [Integer]) -> Property+prop_take = runTest (uncurry_Q Q.take) (\(n,l) -> take (fromIntegral n) l)++prop_drop :: (Integer, [Integer]) -> Property+prop_drop = runTest (uncurry_Q Q.drop) (\(n,l) -> drop (fromIntegral n) l)++-- | Map "id" over the list+prop_map_id :: [Integer] -> Property+prop_map_id = runTest (Q.map id) (map id)++prop_append :: ([Integer], [Integer]) -> Property+prop_append = runTest (uncurry_Q (Q.><)) (\(a,b) -> a ++ b)++-- | filter "const True"+prop_filter_True :: [Integer] -> Property+prop_filter_True = runTest (Q.filter (const $ Q.toQ True)) (filter $ const True)++prop_groupWith_id :: [Integer] -> Property+prop_groupWith_id = runTest (Q.groupWith id) (groupWith id)++prop_sortWith_id :: [Integer] -> Property+prop_sortWith_id = runTest (Q.sortWith id) (sortWith id)++prop_null :: [Integer] -> Property+prop_null = runTest Q.null null++prop_length :: [Integer] -> Property+prop_length = runTest Q.length (fromIntegral . length)++prop_reverse :: [Integer] -> Property+prop_reverse = runTest Q.reverse reverse+++--------------------------------------------------------------------------------+-- Special folds++prop_and :: [Bool] -> Property+prop_and = runTest Q.and and++prop_or :: [Bool] -> Property+prop_or = runTest Q.or or++prop_any_zero :: [Integer] -> Property+prop_any_zero = runTest (Q.any (Q.== 0)) (any (== 0))++prop_all_zero :: [Integer] -> Property+prop_all_zero = runTest (Q.all (Q.== 0)) (all (== 0))++prop_sum_integer :: [Integer] -> Property+prop_sum_integer = runTest Q.sum sum++prop_sum_double :: [Double] -> Property+prop_sum_double = runTestDouble Q.sum sum++prop_concat :: [[Integer]] -> Property+prop_concat = runTest Q.concat concat++prop_concatMap :: [Integer] -> Property+prop_concatMap = runTest (Q.concatMap Q.singleton) (concatMap (\a -> [a]))+++prop_maximum :: [Integer] -> Property+prop_maximum = testNotNull Q.maximum maximum++prop_minimum :: [Integer] -> Property+prop_minimum = testNotNull Q.minimum minimum++--------------------------------------------------------------------------------+-- Sublists++prop_splitAt :: (Integer, [Integer]) -> Property+prop_splitAt = runTest (uncurry_Q Q.splitAt) (\(a,b) -> splitAt (fromIntegral a) b)++prop_takeWhile :: (Integer, [Integer]) -> Property+prop_takeWhile = runTest (uncurry_Q $ Q.takeWhile . (Q.==))+ (uncurry $ takeWhile . (==))++prop_dropWhile :: (Integer, [Integer]) -> Property+prop_dropWhile = runTest (uncurry_Q $ Q.dropWhile . (Q.==))+ (uncurry $ dropWhile . (==))++prop_span :: (Integer, [Integer]) -> Property+prop_span = runTest (uncurry_Q $ Q.span . (Q.==))+ (uncurry $ span . (==) . fromIntegral)++prop_break :: (Integer, [Integer]) -> Property+prop_break = runTest (uncurry_Q $ Q.break . (Q.==))+ (uncurry $ break . (==) . fromIntegral)+++--------------------------------------------------------------------------------+-- Zipping and unzipping lists++prop_zip :: ([Integer], [Integer]) -> Property+prop_zip = runTest (uncurry_Q Q.zip) (uncurry zip)++prop_zipWith_plus :: ([Integer], [Integer]) -> Property+prop_zipWith_plus = runTest (uncurry_Q $ Q.zipWith (+)) (uncurry $ zipWith (+))++prop_unzip :: [(Integer, Integer)] -> Property+prop_unzip = runTest Q.unzip unzip+++--------------------------------------------------------------------------------+-- Set operations++prop_nub :: [Integer] -> Property+prop_nub = runTest Q.nub nub+++--------------------------------------------------------------------------------+-- Tuple projection functions++prop_fst :: (Integer, Integer) -> Property+prop_fst = runTest Q.fst fst++prop_snd :: (Integer, Integer) -> Property+prop_snd = runTest Q.snd snd+++--------------------------------------------------------------------------------+-- Conditionals++prop_cond :: Bool -> Property+prop_cond = runTest (Q.cond Q.empty (Q.toQ [0 :: Integer]))+ (\b -> if b then [] else [0])++--------------------------------------------------------------------------------+-- Numerical Operations++prop_add_integer :: (Integer,Integer) -> Property+prop_add_integer = runTest (uncurry_Q (+)) (uncurry (+))++prop_add_double :: (Double,Double) -> Property+prop_add_double = runTestDouble (uncurry_Q (+)) (uncurry (+))++prop_mul_integer :: (Integer,Integer) -> Property+prop_mul_integer = runTest (uncurry_Q (*)) (uncurry (*))++prop_mul_double :: (Double,Double) -> Property+prop_mul_double = runTestDouble (uncurry_Q (*)) (uncurry (*))++prop_div_double :: (Double,Double) -> Property+prop_div_double (x,y) =+ y /= 0+ ==> runTestDouble (uncurry_Q (/)) (uncurry (/)) (x,y)++prop_integer_to_double :: Integer -> Property+prop_integer_to_double = runTestDouble Q.integerToDouble fromInteger++prop_abs_integer :: Integer -> Property+prop_abs_integer = runTest Q.abs abs++prop_abs_double :: Double -> Property+prop_abs_double = runTestDouble Q.abs abs++prop_signum_integer :: Integer -> Property+prop_signum_integer = runTest Q.signum signum++prop_signum_double :: Double -> Property+prop_signum_double = runTestDouble Q.signum signum++prop_negate_integer :: Integer -> Property+prop_negate_integer = runTest Q.negate negate++prop_negate_double :: Double -> Property+prop_negate_double = runTestDouble Q.negate negate
+ tests/Makefile view
@@ -0,0 +1,16 @@+all: cabal+ ghc -Wall -O3 --make Main.hs -o Main+ ./Main++hpc: cabal+ mkdir tmp+ ghc -Wall -i../src -i../dist/build/autogen -outputdir tmp -fforce-recomp -O3 -fhpc --make Main.hs -o Main+ ./Main+ hpc report Main+ hpc markup Main++cabal: clean+ cd ..; cabal clean; cabal install; cd tests;++clean:+ rm -rf tmp .hpc *.html *.tix *.o *.hi Main