diff --git a/DSH.cabal b/DSH.cabal new file mode 100644 --- /dev/null +++ b/DSH.cabal @@ -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. + +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/examples/Example1.hs b/examples/Example1.hs new file mode 100644 --- /dev/null +++ b/examples/Example1.hs @@ -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 diff --git a/examples/Example1_data.sql b/examples/Example1_data.sql new file mode 100644 --- /dev/null +++ b/examples/Example1_data.sql @@ -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); diff --git a/examples/Example2.hs b/examples/Example2.hs new file mode 100644 --- /dev/null +++ b/examples/Example2.hs @@ -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 diff --git a/src/Database/DSH.hs b/src/Database/DSH.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH.hs @@ -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 + ) diff --git a/src/Database/DSH/CSV.hs b/src/Database/DSH/CSV.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CSV.hs @@ -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 ++ "'") diff --git a/src/Database/DSH/Combinators.hs b/src/Database/DSH/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Combinators.hs @@ -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 + +-} diff --git a/src/Database/DSH/Compile.hs b/src/Database/DSH/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Compile.hs @@ -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) diff --git a/src/Database/DSH/Compiler.hs b/src/Database/DSH/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Compiler.hs @@ -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 diff --git a/src/Database/DSH/Data.hs b/src/Database/DSH/Data.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Data.hs @@ -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) diff --git a/src/Database/DSH/Impossible.hs b/src/Database/DSH/Impossible.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Impossible.hs @@ -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))) diff --git a/src/Database/DSH/Interpreter.hs b/src/Database/DSH/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Interpreter.hs @@ -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 diff --git a/src/Database/DSH/QQ.hs b/src/Database/DSH/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/QQ.hs @@ -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) diff --git a/src/Database/DSH/TH.hs b/src/Database/DSH/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/TH.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 --- /dev/null +++ b/tests/Makefile @@ -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