diff --git a/DSH.cabal b/DSH.cabal --- a/DSH.cabal +++ b/DSH.cabal @@ -1,5 +1,5 @@ Name: DSH -Version: 0.7.8.2 +Version: 0.8.0.1 Synopsis: Database Supported Haskell Description: This is a Haskell library for database-supported program execution. Using @@ -32,6 +32,9 @@ reading. The package includes a couple of examples that demonstrate how to use DSH. . + This is a highly experimental realise supporting our work-in-progress paper on + "Algebraic Data Types for Language-Integrated Queries". + . 1. License: BSD3 @@ -43,44 +46,45 @@ Build-type: Simple Extra-source-files: examples/Example01.hs - examples/Example02.hs examples/Makefile tests/Main.hs tests/Makefile -Cabal-version: >= 1.2 +Cabal-version: >= 1.4 Library - Build-depends: base >= 4.3.1.0 && < 5, - containers >= 0.4.0.0, - array >= 0.3.0.2, - syb >= 0.3, - mtl >= 2.0.1.0, - bytestring >= 0.9.1.10, - text >= 0.11.0.6, - HDBC >= 2.3.1.0, - convertible >= 1.0.11.0, - template-haskell >= 2.5.0.0, - HaXml >= 1.22.5, - csv >= 0.1.2, - json >= 0.5, - xhtml >= 3000.2.0.1, - Pathfinder >= 0.5.10, - FerryCore >= 0.4.6.4 + Extensions: TemplateHaskell, + ScopedTypeVariables, + FlexibleContexts, + FlexibleInstances, + MultiParamTypeClasses, + TypeFamilies, + GADTs + Build-depends: base >= 4.5 && < 5, + containers >= 0.4, + array >= 0.4, + bytestring >= 0.9, + template-haskell >= 2.7, + mtl >= 2.1, + text >= 0.11, + HDBC >= 2.3, + HaXml >= 1.23, + csv >= 0.1, + Pathfinder >= 0.5, + FerryCore >= 0.4 + Hs-source-dirs: src - GHC-options: -O3 -Wall + GHC-options: -O3 -Wall -fno-warn-orphans - Exposed-modules: Database.DSH - Database.DSH.Interpreter + Exposed-modules: Database.DSH.Interpreter Database.DSH.Compiler + Database.DSH - Other-modules: Database.DSH.TH - Database.DSH.Data - Database.DSH.Combinators + Other-modules: Database.DSH.Internals + Database.DSH.Externals Database.DSH.CSV - Database.DSH.JSON - Database.DSH.XHTML Database.DSH.Impossible Database.DSH.Compile + Database.DSH.TH diff --git a/examples/Example02.hs b/examples/Example02.hs deleted file mode 100644 --- a/examples/Example02.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses #-} - -module Main where - -import qualified Prelude as P -import Database.DSH - -import Database.HDBC.PostgreSQL - -$(generateDatabaseRecordInstances (connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'")) -$(generateTableDeclarations (connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'")) - -main :: IO () -main = P.return () diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -1,7 +1,6 @@ all: clean ghc -Wall -O3 --make Example01.hs - ghc -Wall -O3 --make Example02.hs rm -rf *.hi *.o clean: - rm -rf *.hi *.o Example01 Example02 + rm -rf *.hi *.o Example01 diff --git a/src/Database/DSH.hs b/src/Database/DSH.hs --- a/src/Database/DSH.hs +++ b/src/Database/DSH.hs @@ -14,27 +14,8 @@ -- by Database.DSH. module Database.DSH - ( - module Database.DSH.Combinators - - -- * Data Types - , Q - - -- * Type Classes - , QA - , TA, table, tableDB, tableCSV, tableWithKeys, BasicType - , View, view, fromView, tuple, record - - -- * Template Haskell: Creating Table Representations - , generateDatabaseRecordInstances - , generateTableRecordInstances - , generateRecordInstances - , generateTableDeclarations - - , module Database.DSH.CSV - , module Database.DSH.JSON - , module Database.DSH.XHTML - + ( module Database.DSH.Externals + , Q, QA, Elim, elim, View, view, fromView , module Data.String , module Data.Text , module Database.HDBC @@ -42,19 +23,12 @@ ) where -import Database.DSH.Data (Q, QA, TA, table, tableDB, tableCSV, tableWithKeys, BasicType, View, view, fromView, tuple, record) -import Database.DSH.TH (generateDatabaseRecordInstances, generateTableRecordInstances, generateRecordInstances, generateTableDeclarations) - -import Database.DSH.CSV -import Database.DSH.JSON -import Database.DSH.XHTML - -import Database.DSH.Combinators +import Database.DSH.Externals +import Database.DSH.Internals (Q,QA,Elim,elim,View,view,fromView) -import Data.String(IsString,fromString) +import Data.String (IsString,fromString) import Data.Text (Text) import Database.HDBC - import Prelude hiding ( not , (&&) @@ -78,6 +52,7 @@ , null , length , (!!) + , (++) , reverse , and , or diff --git a/src/Database/DSH/CSV.hs b/src/Database/DSH/CSV.hs --- a/src/Database/DSH/CSV.hs +++ b/src/Database/DSH/CSV.hs @@ -1,83 +1,39 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} - -module Database.DSH.CSV (csvImport, csvExport, csvExportHandle, csvExportStdout) where +module Database.DSH.CSV (csvImport) where -import Database.DSH.Data -import Database.DSH.Impossible +import Database.DSH.Internals -import Text.CSV -import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.IO as T - -import qualified System.IO as IO -import System.IO (Handle) - -csvExport :: (QA a) => FilePath -> [a] -> IO () -csvExport file as = IO.withFile file IO.WriteMode (\handle -> csvExportHandle handle as) - -csvExportStdout :: (QA a) => [a] -> IO () -csvExportStdout = csvExportHandle IO.stdout - -csvExportHandle :: (QA a) => Handle -> [a] -> IO () -csvExportHandle handle as = T.hPutStr handle csvContent - where csvContent :: Text - csvContent = T.unlines (map (toRow . toNorm) as) - - quote :: Text -> Text - quote s = T.concat ["\"",s,"\""] - - escape :: Text -> Text - escape = (T.replace "\t" "\\t") . - (T.replace "\r" "\\r") . - (T.replace "\n" "\\n") . - (T.replace "\"" "\"\"") - - toRow :: Norm -> Text - toRow e = case e of - ListN _ _ -> "Nesting" - UnitN _ -> quote "()" - BoolN b _ -> quote (T.pack (show b)) - CharN c _ -> quote (escape (T.singleton c)) - IntegerN i _ -> quote (T.pack (show i)) - DoubleN d _ -> quote (T.pack (show d)) - TextN t _ -> quote (escape t) - TupleN e1 e2 _ -> T.concat [toRow e1,",",toRow e2] - +import Text.CSV -csvImport :: FilePath -> Type -> IO Norm +csvImport :: (Reify a) => FilePath -> Type [a] -> IO (Exp [a]) csvImport filepath csvType = do let rType = recordType csvType contents <- readFile filepath let csv1 = case parseCSV filepath contents of Left er -> error (show er) Right r -> filter (\l -> not (all null l) || length l > 1) (tail r) - return (ListN (fmap (csvRecordToNorm rType) csv1) (ListT rType)) + return (ListE (fmap (csvRecordToNorm rType) csv1)) where csvError :: String -> a csvError s = error ("Error in '" ++ filepath ++ "': " ++ s) - recordType :: Type -> Type + recordType :: Type [a] -> Type a recordType (ListT rType) = rType - recordType _ = $impossible - csvRecordToNorm :: Type -> [String] -> Norm - csvRecordToNorm t rs = case (t,rs) of - (UnitT , [] ) -> UnitN UnitT - (_ , [] ) -> er - (t1 , [bs] ) -> csvFieldToNorm t1 bs - (TupleT t1 t2, bs : bss) -> TupleN (csvFieldToNorm t1 bs) (csvRecordToNorm t2 bss) (TupleT t1 t2) - (_ , _ ) -> er - where er = csvError ("When converting record '" ++ show rs ++ "' to a value of type '" ++ show t ++ "'") + csvRecordToNorm :: Type a -> [String] -> Exp a + csvRecordToNorm UnitT [] = UnitE + csvRecordToNorm t [] = csvError ("When converting record '" ++ "[]" ++ "' to a value of type '" ++ show t ++ "'") + csvRecordToNorm t1 [bs] = csvFieldToNorm t1 bs + csvRecordToNorm (PairT (t1 :: Type b) (t2 :: Type c)) (bs : bss) = PairE (csvFieldToNorm t1 bs :: Exp b) (csvRecordToNorm t2 bss) + csvRecordToNorm t rs = csvError ("When converting record '" ++ show rs ++ "' to a value of type '" ++ show t ++ "'") - csvFieldToNorm :: Type -> String -> Norm + + csvFieldToNorm :: Type a -> String -> Exp a csvFieldToNorm t s = case t of - UnitT -> UnitN UnitT - BoolT -> BoolN (read s) BoolT - CharT -> CharN (head s) CharT - IntegerT -> IntegerN (read s) IntegerT - DoubleT -> DoubleN (read s) DoubleT - TextT -> TextN (T.pack s) TextT - TupleT _ _ -> er - ListT _ -> er - ArrowT _ _ -> er + UnitT -> UnitE + BoolT -> BoolE (read s) + CharT -> CharE (head s) + IntegerT -> IntegerE (read s) + DoubleT -> DoubleE (read s) + TextT -> TextE (T.pack s) + _ -> er where er = csvError ("When converting CSV field'" ++ s ++ "' to a value of type '" ++ show t ++ "'") diff --git a/src/Database/DSH/Combinators.hs b/src/Database/DSH/Combinators.hs deleted file mode 100644 --- a/src/Database/DSH/Combinators.hs +++ /dev/null @@ -1,398 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Database.DSH.Combinators where - -import Database.DSH.Data -import Database.DSH.TH - -import Data.Convertible - -import Prelude (Eq, Ord, Num, Bool(..), Integer, Double, Maybe, Either, undefined, error, ($), (.)) - --- * Unit - -unit :: Q () -unit = Q (UnitE $ reify (undefined :: ())) - --- * Boolean logic - -false :: Q Bool -false = Q (BoolE False BoolT) - -true :: Q Bool -true = Q (BoolE True BoolT) - -not :: Q Bool -> Q Bool -not (Q b) = Q (AppE1 Not b $ reify (undefined :: Bool)) - -(&&) :: Q Bool -> Q Bool -> Q Bool -(&&) (Q a) (Q b) = Q (AppE2 Conj a b $ reify (undefined :: Bool)) - -(||) :: Q Bool -> Q Bool -> Q Bool -(||) (Q a) (Q b) = Q (AppE2 Disj a b $ reify (undefined :: Bool)) - --- * Equality and Ordering - -eq :: (Eq a,QA a) => Q a -> Q a -> Q Bool -eq (Q a) (Q b) = Q (AppE2 Equ a b $ reify (undefined :: Bool)) - -(==) :: (Eq a,QA a) => Q a -> Q a -> Q Bool -(==) = eq - -neq :: (Eq a,QA a) => Q a -> Q a -> Q Bool -neq a b = not (eq a b) - -(/=) :: (Eq a,QA a) => Q a -> Q a -> Q Bool -(/=) = neq - -lt :: (Ord a,QA a) => Q a -> Q a -> Q Bool -lt (Q a) (Q b) = Q (AppE2 Lt a b $ reify (undefined :: Bool)) - -(<) :: (Ord a,QA a) => Q a -> Q a -> Q Bool -(<) = lt - -lte :: (Ord a,QA a) => Q a -> Q a -> Q Bool -lte (Q a) (Q b) = Q (AppE2 Lte a b $ reify (undefined :: Bool)) - -(<=) :: (Ord a,QA a) => Q a -> Q a -> Q Bool -(<=) = lte - -gte :: (Ord a,QA a) => Q a -> Q a -> Q Bool -gte (Q a) (Q b) = Q (AppE2 Gte a b $ reify (undefined :: Bool)) - -(>=) :: (Ord a,QA a) => Q a -> Q a -> Q Bool -(>=) = gte - -gt :: (Ord a,QA a) => Q a -> Q a -> Q Bool -gt (Q a) (Q b) = Q (AppE2 Gt a b $ reify (undefined :: Bool)) - -(>) :: (Ord a,QA a) => Q a -> Q a -> Q Bool -(>) = gt - -min :: forall a. (Ord a, QA a) => Q a -> Q a -> Q a -min (Q a) (Q b) = Q (AppE2 Min a b $ reify (undefined :: a)) - -max :: forall a. (Ord a, QA a) => Q a -> Q a -> Q a -max (Q a) (Q b) = Q (AppE2 Max a b $ reify (undefined :: a)) - - --- * Conditionals --- | Boolean fold --- | It's first argument is used in the case of False --- | It's second argument is used in the case of True --- | The third argument is the boolean -bool :: (QA a) => Q a -> Q a -> Q Bool -> Q a -bool f t b = cond b t f - -cond :: forall a. (QA a) => Q Bool -> Q a -> Q a -> Q a -cond (Q c) (Q a) (Q b) = Q (AppE3 Cond c a b $ reify (undefined :: a)) - -(?) :: (QA a) => Q Bool -> (Q a,Q a) -> Q a -(?) c (a,b) = cond c a b - --- * Maybe - -listToMaybe :: QA a => Q [a] -> Q (Maybe a) -listToMaybe (Q as) = (Q as) - -maybeToList :: QA a => Q (Maybe a) -> Q [a] -maybeToList (Q ma) = (Q ma) - -nothing :: QA a => Q (Maybe a) -nothing = listToMaybe nil - -just :: QA a => Q a -> Q (Maybe a) -just a = listToMaybe (singleton a) - -isNothing :: QA a => Q (Maybe a) -> Q Bool -isNothing ma = null (maybeToList ma) - -isJust :: QA a => Q (Maybe a) -> Q Bool -isJust ma = not (isNothing ma) - -fromJust :: QA a => Q (Maybe a) -> Q a -fromJust ma = head (maybeToList ma) - -maybe :: (QA a, QA b) => Q b -> (Q a -> Q b) -> Q (Maybe a) -> Q b -maybe b f ma = (isNothing ma) ? (b, f (fromJust (ma))) - -fromMaybe :: QA a => Q a -> Q (Maybe a) -> Q a -fromMaybe a ma = (isNothing ma) ? (a, fromJust (ma)) - -catMaybes :: QA a => Q [Maybe a] -> Q [a] -catMaybes mas = concatMap maybeToList mas - -mapMaybe :: (QA a, QA b) => (Q a -> Q (Maybe b)) -> Q [a] -> Q [b] -mapMaybe f as = concatMap (maybeToList . f) as - --- * Either - -left :: (QA a,QA b) => Q a -> Q (Either a b) -left a = tupleToEither (tuple ((singleton a),nil)) - -right :: (QA a,QA b) => Q b -> Q (Either a b) -right a = tupleToEither (tuple (nil,(singleton a))) - -isLeft :: (QA a,QA b) => Q (Either a b) -> Q Bool -isLeft = null . snd . eitherToTuple - -isRight :: (QA a,QA b) => Q (Either a b) -> Q Bool -isRight = null . fst . eitherToTuple - -either :: (QA a,QA b,QA c) => (Q a -> Q c) -> (Q b -> Q c) -> Q (Either a b) -> Q c -either lf rf e = (isLeft e) ? ((lf . head . fst . eitherToTuple) e,(rf . head . snd . eitherToTuple) e) - -lefts :: (QA a,QA b) => Q [Either a b] -> Q [a] -lefts = concatMap (fst . eitherToTuple) - -rights :: (QA a,QA b) => Q [Either a b] -> Q [b] -rights = concatMap (snd . eitherToTuple) - -partitionEithers :: (QA a,QA b) => Q [Either a b] -> Q ([a], [b]) -partitionEithers es = tuple (lefts es,rights es) - --- * List Construction - -nil :: forall a. (QA a) => Q [a] -nil = Q (ListE [] $ reify (undefined :: [a])) - -empty :: (QA a) => Q [a] -empty = nil - -cons :: forall a. (QA a) => Q a -> Q [a] -> Q [a] -cons (Q a) (Q as) = Q (AppE2 Cons a as $ reify (undefined :: [a])) - -(<|) :: (QA a) => Q a -> Q [a] -> Q [a] -(<|) = cons - -snoc :: forall a. (QA a) => Q [a] -> Q a -> Q [a] -snoc (Q as) (Q a) = Q (AppE2 Snoc as a $ reify (undefined :: [a])) - -(|>) :: (QA a) => Q [a] -> Q a -> Q [a] -(|>) = snoc - -singleton :: (QA a) => Q a -> Q [a] -singleton a = cons a nil - --- * List Operations - -head :: forall a. (QA a) => Q [a] -> Q a -head (Q as) = Q (AppE1 Head as $ reify (undefined :: a)) - -tail :: forall a. (QA a) => Q [a] -> Q [a] -tail (Q as) = Q (AppE1 Tail as $ reify (undefined :: [a])) - -take :: forall a. (QA a) => Q Integer -> Q [a] -> Q [a] -take (Q i) (Q as) = Q (AppE2 Take i as $ reify (undefined :: [a])) - -drop :: forall a. (QA a) => Q Integer -> Q [a] -> Q [a] -drop (Q i) (Q as) = Q (AppE2 Drop i as $ reify (undefined :: [a])) - -map :: forall a b. (QA a, QA b) => (Q a -> Q b) -> Q [a] -> Q [b] -map f (Q as) = Q (AppE2 Map (toLam1 f) as $ reify (undefined :: [b])) - -append :: forall a. (QA a) => Q [a] -> Q [a] -> Q [a] -append (Q as) (Q bs) = Q (AppE2 Append as bs $ reify (undefined :: [a])) - -(><) :: (QA a) => Q [a] -> Q [a] -> Q [a] -(><) = append - -filter :: forall a. (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] -filter f (Q as) = Q (AppE2 Filter (toLam1 f) as $ reify (undefined :: [a])) - -groupWith :: forall a b. (Ord b, QA a, QA b) => (Q a -> Q b) -> Q [a] -> Q [[a]] -groupWith f (Q as) = Q (AppE2 GroupWith (toLam1 f) as $ reify (undefined :: [[a]])) - -sortWith :: forall a b. (Ord b, QA a, QA b) => (Q a -> Q b) -> Q [a] -> Q [a] -sortWith f (Q as) = Q (AppE2 SortWith (toLam1 f) as $ reify (undefined :: [a])) - -the :: forall a. (Eq a, QA a) => Q [a] -> Q a -the (Q as) = Q (AppE1 The as $ reify (undefined :: a)) - -last :: forall a. (QA a) => Q [a] -> Q a -last (Q as) = Q (AppE1 Last as $ reify (undefined :: a)) - -init :: forall a. (QA a) => Q [a] -> Q [a] -init (Q as) = Q (AppE1 Init as $ reify (undefined :: [a])) - -null :: (QA a) => Q [a] -> Q Bool -null (Q as) = Q (AppE1 Null as $ reify (undefined :: Bool)) - -length :: (QA a) => Q [a] -> Q Integer -length (Q as) = Q (AppE1 Length as $ reify (undefined :: Integer)) - -index :: forall a. (QA a) => Q [a] -> Q Integer -> Q a -index (Q as) (Q i) = Q (AppE2 Index as i $ reify (undefined :: a)) - -(!!) :: (QA a) => Q [a] -> Q Integer -> Q a -(!!) = index - -reverse :: forall a. (QA a) => Q [a] -> Q [a] -reverse (Q as) = Q (AppE1 Reverse as $ reify (undefined :: [a])) - - --- * Special folds - -and :: Q [Bool] -> Q Bool -and (Q as) = Q (AppE1 And as $ reify (undefined :: Bool)) - -or :: Q [Bool] -> Q Bool -or (Q as) = Q (AppE1 Or as $ reify (undefined :: Bool)) - -any :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q Bool -any f (Q as) = Q (AppE2 Any (toLam1 f) as $ reify (undefined :: Bool)) - -all :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q Bool -all f (Q as) = Q (AppE2 All (toLam1 f) as $ reify (undefined :: Bool)) - -sum :: forall a. (QA a, Num a) => Q [a] -> Q a -sum (Q as) = Q (AppE1 Sum as $ reify (undefined :: a)) - -concat :: forall a. (QA a) => Q [[a]] -> Q [a] -concat (Q as) = Q (AppE1 Concat as $ reify (undefined :: [a])) - -concatMap :: (QA a, QA b) => (Q a -> Q [b]) -> Q [a] -> Q [b] -concatMap f as = concat (map f as) - -maximum :: forall a. (QA a, Ord a) => Q [a] -> Q a -maximum (Q as) = Q (AppE1 Maximum as $ reify (undefined :: a)) - -minimum :: forall a. (QA a, Ord a) => Q [a] -> Q a -minimum (Q as) = Q (AppE1 Minimum as $ reify (undefined :: a)) - --- * Sublists - -splitAt :: forall a. (QA a) => Q Integer -> Q [a] -> Q ([a], [a]) -splitAt (Q i) (Q as) = Q (AppE2 SplitAt i as $ reify (undefined :: ([a],[a]))) - -takeWhile :: forall a. (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] -takeWhile f (Q as) = Q (AppE2 TakeWhile (toLam1 f) as $ reify (undefined :: [a])) - -dropWhile :: forall a. (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] -dropWhile f (Q as) = Q (AppE2 DropWhile (toLam1 f) as $ reify (undefined :: [a])) - -span :: forall a. (QA a) => (Q a -> Q Bool) -> Q [a] -> Q ([a],[a]) -span f (Q as) = Q (AppE2 Span (toLam1 f) as $ reify (undefined :: ([a],[a]))) - -break :: forall a. (QA a) => (Q a -> Q Bool) -> Q [a] -> Q ([a],[a]) -break f (Q as) = Q (AppE2 Break (toLam1 f) as $ reify (undefined :: ([a],[a]))) - - --- * Searching Lists - -elem :: forall a. (Eq a, QA a) => Q a -> Q [a] -> Q Bool -elem a as = (null (filter (a ==) as)) ? (false,true) - -notElem :: forall a. (Eq a, QA a) => Q a -> Q [a] -> Q Bool -notElem a as = not (elem a as) - -lookup :: (QA a,QA b,Eq a) => Q a -> Q [(a, b)] -> Q (Maybe b) -lookup a = listToMaybe . map snd . filter ((a ==) . fst) - --- * Zipping and Unzipping Lists - -zip :: forall a b. (QA a, QA b) => Q [a] -> Q [b] -> Q [(a,b)] -zip (Q as) (Q bs) = Q (AppE2 Zip as bs $ reify (undefined :: [(a,b)])) - -zipWith :: forall a b c. (QA a, QA b, QA c) => (Q a -> Q b -> Q c) -> Q [a] -> Q [b] -> Q [c] -zipWith f (Q as) (Q bs) = Q (AppE3 ZipWith (toLam2 f) as bs $ reify (undefined :: [c])) - -unzip :: forall a b. (QA a, QA b) => Q [(a,b)] -> Q ([a], [b]) -unzip (Q as) = Q (AppE1 Unzip as $ reify (undefined :: ([a],[b]))) - --- * "Set" operations - -nub :: forall a. (Eq a,QA a) => Q [a] -> Q [a] -nub (Q as) = Q (AppE1 Nub as $ reify (undefined :: [a])) - - --- * Tuple Projection Functions - -fst :: forall a b. (QA a, QA b) => Q (a,b) -> Q a -fst (Q a) = Q (AppE1 Fst a $ reify (undefined :: a)) - -snd :: forall a b. (QA a, QA b) => Q (a,b) -> Q b -snd (Q a) = Q (AppE1 Snd a $ reify (undefined :: b)) - - --- * Conversions between numeric types - -integerToDouble :: Q Integer -> Q Double -integerToDouble (Q a) = Q (AppE1 IntegerToDouble a DoubleT) - --- * Convert Haskell values into DB queries - -toQ :: forall a. (QA a) => a -> Q a -toQ c = Q (convert (toNorm c)) - --- * Rebind Monadic Combinators - -return :: (QA a) => Q a -> Q [a] -return = singleton - -(>>=) :: (QA a, QA b) => Q [a] -> (Q a -> Q [b]) -> Q [b] -(>>=) ma f = concatMap f ma - -(>>) :: (QA a, QA b) => Q [a] -> Q [b] -> Q [b] -(>>) ma mb = concatMap (\_ -> mb) ma - -mzip :: (QA a, QA b) => Q [a] -> Q [b] -> Q [(a,b)] -mzip = zip - -guard :: Q Bool -> Q [()] -guard c = cond c (singleton unit) nil - -infixl 9 !! -infixr 5 ><, <|, |> -infix 4 ==, /=, <, <=, >=, > -infixr 3 && -infixr 2 || -infix 0 ? - --- 'QA', 'TA' and 'View' instances for tuples up to the defined length. - -$(generateDeriveTupleQARange 3 60) -$(generateDeriveTupleTARange 3 16) -$(generateDeriveTupleViewRange 3 16) - - --- * Missing Combinators --- $missing - -{- $missing - -This module offers most of the functions on lists given in PreludeList for the -'Q' type. Missing functions are: - -General folds: - -> foldl -> foldl1 -> scanl -> scanl1 -> foldr -> foldr1 -> scanr -> scanr1 - -Infinit lists: - -> iterate -> repeat -> cycle - -String functions: - -> lines -> words -> unlines -> unwords - -Zipping and unzipping lists: - -> zip3 -> zipWith3 -> unzip3 - --} diff --git a/src/Database/DSH/Compile.hs b/src/Database/DSH/Compile.hs --- a/src/Database/DSH/Compile.hs +++ b/src/Database/DSH/Compile.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, ParallelListComp #-} module Database.DSH.Compile where -import Database.DSH.Data -import Database.DSH.Impossible (impossible) +import Database.DSH.Internals +import Database.DSH.Impossible import Database.Pathfinder import qualified Data.Array as A import qualified Data.List as L -import Data.Maybe (fromJust, isNothing, isJust) +import Data.Maybe (fromJust, isNothing, isJust, fromMaybe) import Data.List (sortBy) +import Data.Function +import Control.Arrow import Control.Monad.Reader import Control.Exception (evaluate) @@ -17,7 +18,8 @@ import Text.XML.HaXml (Content(..), AttValue(..), tag, deep, children, xmlParse, Document(..)) import Database.HDBC -import Data.Convertible +import qualified Data.Text as T +import qualified Data.Text.Encoding as T -- | Wrapper type with phantom type for algebraic plan -- The type variable represents the type of the result of the plan @@ -48,7 +50,7 @@ -- | Translate the algebraic plan to SQL and then execute it using the provided -- DB connection. If debug is switchd on the SQL code is written to a file -- named query.sql -executePlan :: forall a. forall conn. (QA a, IConnection conn) => conn -> AlgebraXML a -> IO Norm +executePlan :: forall a. forall conn. (Reify a, IConnection conn) => conn -> AlgebraXML a -> IO (Exp a) executePlan c p = do sql@(SQL _s) <- algToSQL p runSQL c $ extractSQL sql @@ -75,28 +77,26 @@ extractSQL (SQL q) = let (Document _ _ r _) = xmlParse "query" q in Bundle $ map extractQuery $ (deep $ tag "query_plan") (CElem r $impossible) where - extractQuery c@(CElem (X.Elem n attrs cs) _) = let qId = case fmap attrToInt $ lookup (X.N "id") attrs of - Just x -> x - Nothing -> $impossible + extractQuery c@(CElem (X.Elem n attrs cs) _) = let qId = maybe ($impossible) attrToInt (lookup (X.N "id") attrs) rId = fmap attrToInt $ lookup (X.N "idref") attrs cId = fmap attrToInt $ lookup (X.N "colref") attrs ref = liftM2 (,) rId cId query = extractCData $ head $ concatMap children $ deep (tag "query") c - schema = toSchemeInf $ map process $ concatMap (\x -> deep (tag "column") x) $ deep (tag "schema") c + schema = toSchemeInf $ map process $ concatMap (deep (tag "column")) $ deep (tag "schema") c in (qId, (query, schema, ref)) extractQuery _ = $impossible attrToInt :: AttValue -> Int - attrToInt (AttValue [(Left i)]) = read i + attrToInt (AttValue [Left i]) = read i attrToInt _ = $impossible attrToString :: AttValue -> String - attrToString (AttValue [(Left i)]) = i + attrToString (AttValue [Left i]) = i attrToString _ = $impossible extractCData :: Content i -> String extractCData (CString _ d _) = d extractCData _ = $impossible toSchemeInf :: [(String, Maybe Int)] -> SchemaInfo toSchemeInf results = let iterName = fst $ head $ filter (\(_, p) -> isNothing p) results - cols = map (\(n, v) -> (n, fromJust v)) $ filter (\(_, p) -> isJust p) results + cols = map (second fromJust) $ filter (\(_, p) -> isJust p) results in SchemaInfo iterName cols process :: Content i -> (String, Maybe Int) process (CElem (X.Elem _ attrs _) _) = let name = fromJust $ fmap attrToString $ lookup (X.N "name") attrs @@ -105,15 +105,15 @@ process _ = $impossible -- | Execute the given SQL queries and assemble the results into one structure -runSQL :: forall a. forall conn. (QA a, IConnection conn) => conn -> QueryBundle a -> IO Norm +runSQL :: forall a. forall conn. (Reify a, IConnection conn) => conn -> QueryBundle a -> IO (Exp a) runSQL c (Bundle queries) = do results <- mapM (runQuery c) queries let (queryMap, valueMap) = foldr buildRefMap ([],[]) results let ty = reify (undefined :: a) let results' = runReader (processResults 0 ty) (queryMap, valueMap) - return $ case lookup 1 results' of - Just x -> x - Nothing -> ListN [] ty + case ty of + (ListT _) -> return $ fromMaybe (ListE []) (lookup 1 results') + _ -> return $ fromJust (lookup 1 results') -- | Type of the environment under which we reconstruct ordinary haskell data from the query result. -- The first component of the reader monad contains a mapping from (queryNumber, columnNumber) to @@ -141,49 +141,86 @@ findQuery :: (Int, Int) -> QueryR Int findQuery (q, c) = do env <- ask - return $ (\x -> case x of - Just x' -> x' - Nothing -> error $ show $ fst env) $ lookup (q, c + 1) $ fst env + return $ fromMaybe (error $ show $ fst env) $ lookup (q, c + 1) $ fst env -- | Reconstruct the haskell value out of the result of query i with type ty. -processResults :: Int -> Type -> QueryR [(Int, Norm)] -processResults i ty@(ListT t1) = do +processResults :: Int -> Type a -> QueryR [(Int, Exp a)] +processResults i (ListT t1) = do v <- getResults i mapM (\(it, vals) -> do v1 <- processResults' i 0 vals t1 - return (it, ListN v1 ty)) v + return (it, ListE v1)) v processResults i t = do v <- getResults i mapM (\(it, vals) -> do v1 <- processResults' i 0 vals t return (it, head v1)) v +nrColsInType :: Type a -> Int +nrColsInType UnitT = 1 +nrColsInType BoolT = 1 +nrColsInType CharT = 1 +nrColsInType IntegerT = 1 +nrColsInType DoubleT = 1 +nrColsInType TextT = 1 +nrColsInType (PairT t1 t2) = nrColsInType t1 + nrColsInType t2 +nrColsInType (ListT _) = 1 +nrColsInType (ArrowT _ _) = $impossible + -- | Reconstruct the values for column c of query q out of the rawData vals with type t. -processResults' :: Int -> Int -> [[SqlValue]] -> Type -> QueryR [Norm] -processResults' _ _ vals UnitT = return $ map (\_ -> UnitN UnitT) vals -processResults' q c vals t@(TupleT t1 t2) = do +processResults' :: Int -> Int -> [[SqlValue]] -> Type a -> QueryR [Exp a] +processResults' _ _ vals UnitT = return $ map (\_ -> UnitE) vals +processResults' q c vals (PairT t1 t2) = do v1s <- processResults' q c vals t1 - v2s <- processResults' q (c + 1) vals t2 - return $ [TupleN v1 v2 t | v1 <- v1s | v2 <- v2s] + v2s <- processResults' q (c + nrColsInType t1) vals t2 + return (zipWith PairE v1s v2s) processResults' q c vals t@(ListT _) = do nestQ <- findQuery (q, c) list <- processResults nestQ t i <- getColResPos q c - let (maxV, vals') = foldr (\v (m,vs) -> let v' = (convert $ v !! i)::Int - in (m `max` v', v':vs)) (1,[]) vals + let (maxV, vals') = foldr (\v (m,vs) -> let v' = sqlValueToInt (v !! i) + in (m `max` v', v':vs)) (1,[]) vals let maxI = if null list then 1 - else fst $ L.maximumBy (\x y -> fst x `compare` fst y) list - let lA = (A.accumArray ($impossible) Nothing (1,maxI `max` maxV) []) A.// map (\(x,y) -> (x, Just y)) list - return $ map (\val -> case lA A.! val of - Just x -> x - Nothing -> ListN [] t) vals' -processResults' _ _ _ (ArrowT _ _) = $impossible -- The result cannot be a function + else fst $ L.maximumBy (compare `on` fst) list + let lA = A.accumArray ($impossible) Nothing (1,maxI `max` maxV) [] A.// map (second Just) list + return $ map (\val -> fromMaybe (ListE []) (lA A.! val)) vals' +processResults' _ _ _ (ArrowT _ _) = $impossible processResults' q c vals t = do i <- getColResPos q c - return $ map (\val -> convert $ (val !! i, t)) vals + return $ map (\val -> convert (val !! i) t) vals +sqlValueToInt :: SqlValue -> Int +sqlValueToInt (SqlInteger i) = fromIntegral i +sqlValueToInt _ = $impossible +convert :: SqlValue -> Type a -> Exp a +convert SqlNull UnitT = UnitE +convert (SqlInteger i) IntegerT = IntegerE i +convert (SqlInt32 i) IntegerT = IntegerE $ fromIntegral i +convert (SqlInt64 i) IntegerT = IntegerE $ fromIntegral i +convert (SqlWord32 i) IntegerT = IntegerE $ fromIntegral i +convert (SqlWord64 i) IntegerT = IntegerE $ fromIntegral i +convert (SqlDouble d) DoubleT = DoubleE d +convert (SqlRational d) DoubleT = DoubleE $ fromRational d +convert (SqlInteger d) DoubleT = DoubleE $ fromIntegral d +convert (SqlInt32 d) DoubleT = DoubleE $ fromIntegral d +convert (SqlInt64 d) DoubleT = DoubleE $ fromIntegral d +convert (SqlWord32 d) DoubleT = DoubleE $ fromIntegral d +convert (SqlWord64 d) DoubleT = DoubleE $ fromIntegral d +convert (SqlBool b) BoolT = BoolE b +convert (SqlInteger i) BoolT = BoolE (i /= 0) +convert (SqlInt32 i) BoolT = BoolE (i /= 0) +convert (SqlInt64 i) BoolT = BoolE (i /= 0) +convert (SqlWord32 i) BoolT = BoolE (i /= 0) +convert (SqlWord64 i) BoolT = BoolE (i /= 0) +convert (SqlChar c) CharT = CharE c +convert (SqlString (c:_)) CharT = CharE c +convert (SqlByteString c) CharT = CharE (head $ T.unpack $ T.decodeUtf8 c) +convert (SqlString t) TextT = TextE (T.pack t) +convert (SqlByteString s) TextT = TextE (T.decodeUtf8 s) +convert sql _ = error $ "Unsupported SqlValue: " ++ show sql + -- | Partition by iter column -- The first argument is the position of the iter column. -- The second argument the raw data @@ -194,7 +231,7 @@ in (i, v:vi) : partByIter n vr where getIter :: Int -> [SqlValue] -> Int - getIter n' vals = ((fromSql (vals !! n'))::Int) + getIter n' vals = fromSql (vals !! n') :: Int partByIter _ [] = [] @@ -224,11 +261,11 @@ -- | Transform algebraic plan scheme info into resultinfo schemeToResult :: SchemaInfo -> [(String, SqlColDesc)] -> ResultInfo schemeToResult (SchemaInfo itN cols) resDescr = let ordCols = sortBy (\(_, c1) (_, c2) -> compare c1 c2) cols - resColumns = flip zip [0..] $ map (\(c, _) -> takeWhile (\a -> a /= '_') c) resDescr + resColumns = flip zip [0..] $ map (\(c, _) -> takeWhile (/= '_') c) resDescr itC = fromJust $ lookup itN resColumns in ResultInfo itC $ map (\(n, _) -> (n, fromJust $ lookup n resColumns)) ordCols -- | buildRefMap :: (Int, ([(Int, [[SqlValue]])], ResultInfo, Maybe (Int, Int))) -> ([((Int, Int), Int)] ,[(Int, ([(Int, [[SqlValue]])], ResultInfo))]) -> ([((Int, Int), Int)] ,[(Int, ([(Int, [[SqlValue]])], ResultInfo))]) -buildRefMap (q, (r, ri, (Just (t, c)))) (qm, rm) = (((t, c), q):qm, (q, (r, ri)):rm) +buildRefMap (q, (r, ri, Just (t, c))) (qm, rm) = (((t, c), q):qm, (q, (r, ri)):rm) buildRefMap (q, (r, ri, _)) (qm, rm) = (qm, (q, (r, ri)):rm) diff --git a/src/Database/DSH/Compiler.hs b/src/Database/DSH/Compiler.hs --- a/src/Database/DSH/Compiler.hs +++ b/src/Database/DSH/Compiler.hs @@ -3,13 +3,11 @@ -- FerryCore which is then translated into SQL (through a table algebra). The SQL -- code is executed on the database and then processed to form a Haskell value. -{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, ScopedTypeVariables #-} - -module Database.DSH.Compiler (fromQ, debugPlan, debugCore, debugPlanOpt, debugSQL) where +module Database.DSH.Compiler (fromQ, debugPlan, debugCore, debugPlanOpt, debugSQL, debugCoreDot) where -import Database.DSH.Data as D -import Database.DSH.Impossible (impossible) -import Database.DSH.CSV (csvImport) +import Database.DSH.Internals as D +import Database.DSH.Impossible +import Database.DSH.CSV import Database.DSH.Compile as C @@ -19,7 +17,6 @@ import qualified Data.Map as M import Data.Char import Database.HDBC -import Data.Convertible import Control.Monad.State import Control.Applicative @@ -29,12 +26,10 @@ import Data.List (nub) import qualified Data.List as L -import Data.Generics (listify) - {- N monad, version of the state monad that can provide fresh variable names. -} -type N conn = StateT (conn, Int, M.Map String [(String, (FType -> Bool))]) IO +type N conn = StateT (conn, Int, M.Map String [(String,FType -> Bool)]) IO -- | Provide a fresh identifier name during compilation freshVar :: N conn Int @@ -52,7 +47,7 @@ -- | Lookup information that describes a table. If the information is -- not present in the state then the connection is used to retrieve the -- table information from the Database. -tableInfo :: IConnection conn => String -> N conn [(String, (FType -> Bool))] +tableInfo :: IConnection conn => String -> N conn [(String,FType -> Bool)] tableInfo t = do (c, i, env) <- get case M.lookup t env of @@ -64,7 +59,7 @@ -- | Turn a given integer into a variable beginning with prefix "__fv_" prefixVar :: Int -> String -prefixVar = ((++) "__fv_") . show +prefixVar = (++) "__fv_" . show -- | Execute the transformation computation. During -- compilation table information can be retrieved from @@ -77,157 +72,167 @@ -- | Execute the query on the database fromQ :: (QA a, IConnection conn) => conn -> Q a -> IO a -fromQ c a = evaluate c a >>= (return . fromNorm) - +fromQ c (Q e) = fmap frExp (evaluate c e) -- | Convert the query into unoptimised algebraic plan -debugPlan :: (QA a, IConnection conn) => conn -> Q a -> IO String +debugPlan :: (IConnection conn,Reify a) => conn -> Exp a -> IO String debugPlan = doCompile -- | Convert the query into optimised algebraic plan -debugPlanOpt :: (QA a, IConnection conn) => conn -> Q a -> IO String +debugPlanOpt :: (IConnection conn,Reify a) => conn -> Exp a -> IO String debugPlanOpt q c = do p <- doCompile q c - (C.Algebra r) <- algToAlg ((C.Algebra p)::AlgebraXML a) + (C.Algebra r) <- algToAlg (C.Algebra p :: AlgebraXML a) return r -debugCore :: (QA a, IConnection conn) => conn -> Q a -> IO String -debugCore c (Q a) = do - core <- runN c $ transformE a - return $ show core +debugCore :: (IConnection conn,Reify a) => conn -> Exp a -> IO String +debugCore c a = do core <- runN c $ transformE a + return $ show core + +debugCoreDot :: (IConnection conn,Reify a) => conn -> Exp a -> IO String +debugCoreDot c a = do core <- runN c $ transformE a + return $ (\(Right d) -> d) $ dot core + -- | Convert the query into SQL -debugSQL :: (QA a, IConnection conn) => conn -> Q a -> IO String -debugSQL q c = do - p <- doCompile q c - (C.SQL r) <- algToSQL ((C.Algebra p)::AlgebraXML a) - return r +debugSQL :: (IConnection conn,Reify a) => conn -> Exp a -> IO String +debugSQL q c = do p <- doCompile q c + (C.SQL r) <- algToSQL (C.Algebra p :: AlgebraXML a) + return r -- | evaluate compiles the given Q query into an executable plan, executes this and returns -- the result as norm. For execution it uses the given connection. If the boolean flag is set -- to true it outputs the intermediate algebraic plan to disk. -evaluate :: forall a. forall conn. (QA a, IConnection conn) - => conn - -> Q a - -> IO Norm -evaluate c q = do - algPlan' <- doCompile c q - let algPlan = ((C.Algebra algPlan') :: AlgebraXML a) +evaluate :: (Reify a, IConnection conn) => conn -> Exp a -> IO (Exp a) +evaluate c q = do algPlan' <- doCompile c q + let algPlan = C.Algebra algPlan' :: AlgebraXML a n <- executePlan c algPlan disconnect c return n -- | Transform a query into an algebraic plan. -doCompile :: IConnection conn => conn -> Q a -> IO String -doCompile c (Q a) = do - core <- runN c $ transformE a - return $ typedCoreToAlgebra core +doCompile :: (IConnection conn, Reify a) => conn -> Exp a -> IO String +doCompile c a = do core <- runN c $ transformE a + return $ typedCoreToAlgebra core -- | Transform the Query into a ferry core program. -transformE :: IConnection conn => Exp -> N conn CoreExpr -transformE (UnitE _) = return $ Constant ([] :=> int) $ CInt 1 -transformE (BoolE b _) = return $ Constant ([] :=> bool) $ CBool b -transformE (CharE c _) = return $ Constant ([] :=> string) $ CString [c] -transformE (IntegerE i _) = return $ Constant ([] :=> int) $ CInt i -transformE (DoubleE d _) = return $ Constant ([] :=> float) $ CFloat d -transformE (TextE t _) = return $ Constant ([] :=> string) $ CString $ unpack t -transformE (TupleE e1 e2 ty) = do - c1 <- transformE e1 - c2 <- transformE e2 - return $ Rec ([] :=> transformTy ty) [RecElem (typeOf c1) "1" c1, RecElem (typeOf c2) "2" c2] -transformE (ListE es ty) = let qt = ([] :=> transformTy ty) - in foldr (\h t -> F.Cons qt h t) (Nil qt) <$> mapM transformE es -transformE (AppE1 f1 e1 ty) = do - let tr = transformTy ty - e1' <- transformArg e1 - let (_ :=> ta) = typeOf e1' - return $ App ([] :=> tr) (transformF f1 (ta .-> tr)) e1' --- transformE ((AppE2 GroupWith fn e) ::: ty) = transformE $ ListE [e] ::: ty -transformE (AppE2 Span f e t@(TupleT t1 t2)) = transformE $ TupleE (AppE2 TakeWhile f e t1) (AppE2 DropWhile f e t2) t -transformE (AppE2 Break (LamE f _) e t@(TupleT t1 _)) = let notF = LamE (\x -> AppE1 Not (f x) BoolT) $ ArrowT t1 BoolT - in transformE $ AppE2 Span notF e t -transformE (AppE2 GroupWith gfn e ty@(ListT (ListT tel))) = do - let tr = transformTy ty - fn' <- transformArg gfn - let (_ :=> tfn@(FFn _ rt)) = typeOf fn' - let gtr = list $ rec [(RLabel "1", rt), (RLabel "2", transformTy $ ListT tel)] - e' <- transformArg e - let (_ :=> te) = typeOf e' - fv <- transformArg (LamE id $ ArrowT tel tel) - snd' <- transformArg (LamE (\x -> AppE1 Snd x $ ArrowT (TupleT (transformTy' rt) (ListT tel)) (ListT tel)) $ ArrowT (TupleT (transformTy' rt) (ListT tel)) (ListT tel)) - let (_ :=> sndTy) = typeOf snd' - let (_ :=> tfv) = typeOf fv - return $ App ([] :=> tr) - (App ([] :=> gtr .-> tr) (Var ([] :=> sndTy .-> gtr .-> tr) "map") snd') - (ParExpr ([] :=> gtr) $ App ([] :=> gtr) - (App ([] :=> te .-> gtr) - (App ([] :=> tfn .-> te .-> gtr) (Var ([] :=> tfv .-> tfn .-> te .-> gtr) "groupWith") fv) - fn' - ) - e') -transformE (AppE2 D.Cons e1 e2 _) = do +transformE :: forall a conn. (IConnection conn, Reify a) => Exp a -> N conn CoreExpr +transformE (UnitE ) = return $ Constant ([] :=> int) $ CInt 1 +transformE (BoolE b) = return $ Constant ([] :=> bool) $ CBool b +transformE (CharE c) = return $ Constant ([] :=> string) $ CString [c] +transformE (IntegerE i) = return $ Constant ([] :=> int) $ CInt i +transformE (DoubleE d) = return $ Constant ([] :=> float) $ CFloat d +transformE (TextE t) = return $ Constant ([] :=> string) $ CString $ unpack t +transformE (PairE e1 e2) = do let ty = reify (undefined :: a) + c1 <- transformE e1 + c2 <- transformE e2 + return $ Rec ([] :=> transformTy ty) [RecElem (typeOf c1) "1" c1, RecElem (typeOf c2) "2" c2] +transformE (ListE es) = let ty = reify (undefined :: a) + qt = ([] :=> transformTy ty) + in foldr (F.Cons qt) (Nil qt) <$> mapM transformE es +transformE (AppE GroupWith (PairE (gfn :: Exp (ta -> rt)) (e :: Exp el))) = do + let ty = reify (undefined :: a) + let tel = reify (undefined :: el) + let tr = transformTy ty + fn' <- transformLamArg gfn + let (_ :=> tfn@(FFn _ rt)) = typeOf fn' + let gtr = list $ rec [(RLabel "1", rt), (RLabel "2", transformTy $ ListT tel)] + e' <- transformArg e + let (_ :=> te) = typeOf e' + fv <- transformLamArg (LamE id :: Exp (el -> el)) + snd' <- transformLamArg (LamE (\(x :: Exp (rt,[el])) -> AppE Snd x)) + let (_ :=> sndTy) = typeOf snd' + let (_ :=> tfv) = typeOf fv + return $ App ([] :=> tr) + (App ([] :=> gtr .-> tr) (Var ([] :=> sndTy .-> gtr .-> tr) "map") snd') + (ParExpr ([] :=> gtr) $ App ([] :=> gtr) + (App ([] :=> te .-> gtr) + (App ([] :=> tfn .-> te .-> gtr) (Var ([] :=> tfv .-> tfn .-> te .-> gtr) "groupWith") fv) + fn' + ) + e') +transformE (AppE D.Cons (PairE e1 e2)) = do e1' <- transformE e1 e2' <- transformE e2 let (_ :=> t) = typeOf e1' return $ F.Cons ([] :=> list t) e1' e2' -transformE (AppE2 Append e1 e2 t) = transformE (AppE1 Concat (ListE [e1, e2] (ListT t)) t) -transformE (AppE2 Any f e _) = transformE $ AppE1 Or (AppE2 Map f e $ ListT BoolT) BoolT -transformE (AppE2 All f e _) = transformE $ AppE1 And (AppE2 Map f e $ ListT BoolT) BoolT -transformE (AppE2 Snoc e1 e2 t) = transformE (AppE2 Append e1 (ListE [e2] t) t) -transformE (AppE2 f2 e1 e2 ty) = do - let tr = transformTy ty - case elem f2 [Add, Sub, Mul, Div, Equ, Lt, Lte, Gte, Gt, Conj, Disj] of - True -> do - e1' <- transformE e1 - e2' <- transformE e2 - return $ BinOp ([] :=> tr) (transformOp f2) e1' e2' - False -> do - e1' <- transformArg e1 - e2' <- transformArg e2 - let (_ :=> ta1) = typeOf e1' - let (_ :=> ta2) = typeOf e2' - return $ App ([] :=> tr) - (App ([] :=> ta2 .-> tr) (transformF f2 (ta1 .-> ta2 .-> tr)) e1') - e2' -transformE (AppE3 Cond e1 e2 e3 _) = do +transformE (AppE Cond (PairE e1 (PairE e2 e3))) = do e1' <- transformE e1 e2' <- transformE e2 e3' <- transformE e3 let (_ :=> t) = typeOf e2' return $ If ([] :=> t) e1' e2' e3' -transformE (AppE3 f3 e1 e2 e3 ty) = do - let tr = transformTy ty - e1' <- transformArg e1 - e2' <- transformArg e2 - e3' <- transformArg e3 - let (_ :=> ta1) = typeOf e1' - let (_ :=> ta2) = typeOf e2' - let (_ :=> ta3) = typeOf e3' - return $ App ([] :=> tr) - (App ([] :=> ta3 .-> tr) - (App ([] :=> ta2 .-> ta3 .-> tr) (transformF f3 (ta1 .-> ta2 .-> ta3 .-> tr)) e1') - e2') - e3' -transformE (VarE i ty) = return $ Var ([] :=> transformTy ty) $ prefixVar i -transformE (TableE (TableCSV filepath) ty) = do - norm1 <- lift (csvImport filepath ty) - transformE (convert norm1) +transformE (AppE Fst (PairE e1 e2)) = do + let ty = reify (undefined :: a) + let tr = transformTy ty + e1' <- transformArg (PairE e1 e2) + let (_ :=> ta) = typeOf e1' + return $ App ([] :=> tr) (transformF Fst (ta .-> tr)) e1' + +transformE (AppE Snd (PairE e1 e2)) = do + let ty = reify (undefined :: a) + let tr = transformTy ty + e1' <- transformArg (PairE e1 e2) + let (_ :=> ta) = typeOf e1' + return $ App ([] :=> tr) (transformF Snd (ta .-> tr)) e1' + +transformE (AppE f2 (PairE (LamE f) e)) = do + let ty = reify (undefined :: a) + let tr = transformTy ty + f' <- transformLamArg (LamE f) + e' <- transformArg e + let (_ :=> t1) = typeOf f' + let (_ :=> t2) = typeOf e' + return $ App ([] :=> tr) + (App ([] :=> t2 .-> tr) (transformF f2 (t1 .-> t2 .-> tr)) f') + e' + +transformE (AppE f2 (PairE e1 e2)) = do + let ty = reify (undefined :: a) + let tr = transformTy ty + if isOp f2 + then do e1' <- transformE e1 + e2' <- transformE e2 + return $ BinOp ([] :=> tr) (transformOp f2) e1' e2' + else do e1' <- transformArg e1 + e2' <- transformArg e2 + let (_ :=> ta1) = typeOf e1' + let (_ :=> ta2) = typeOf e2' + return $ App ([] :=> tr) (App ([] :=> ta2 .-> tr) (transformF f2 (ta1 .-> ta2 .-> tr)) e1') e2' + +transformE (AppE f1 e1) = do + let ty = reify (undefined :: a) + let tr = transformTy ty + e1' <- transformArg e1 + let (_ :=> ta) = typeOf e1' + return $ App ([] :=> tr) (transformF f1 (ta .-> tr)) e1' + +transformE (VarE i) = do + let ty = reify (undefined :: a) + return $ Var ([] :=> transformTy ty) $ prefixVar $ fromIntegral i + +transformE (TableE (TableCSV filepath)) = do + let ty = reify (undefined :: a) + e1 <- lift (csvImport filepath ty) + transformE e1 + -- When a table node is encountered check that the given description -- matches the actual table information in the database. -transformE (TableE (TableDB n ks) ty) = do +transformE (TableE (TableDB n ks)) = do + let ty = reify (undefined :: a) fv <- freshVar let tTy@(FList (FRec ts)) = flatFTy ty let varB = Var ([] :=> FRec ts) $ prefixVar fv tableDescr <- tableInfo n - let tyDescr = case length tableDescr == length ts of - True -> zip tableDescr ts - False -> error $ "Inferred typed: " ++ show tTy ++ " \n doesn't match type of table: \"" - ++ n ++ "\" in the database. The table has the shape: " ++ (show $ map fst tableDescr) ++ ". " ++ show ty + let tyDescr = if length tableDescr == length ts + then zip tableDescr ts + else error $ "Inferred typed: " ++ show tTy ++ " \n doesn't match type of table: \"" + ++ n ++ "\" in the database. The table has the shape: " ++ show (map fst tableDescr) ++ ". " ++ show ty let cols = [Column cn t | ((cn, f), (RLabel i, t)) <- tyDescr, legalType n cn i t f] - let keyCols = (nub $ concat ks) L.\\ (map fst tableDescr) - let keys = if (keyCols == []) - then if (ks /= []) then map Key ks else [Key $ map (\(Column n' _) -> n') cols] - else error $ "The following columns were used as key but not a column of table " ++ n ++ " : " ++ show keyCols + let keyCols = nub (concat ks) L.\\ map fst tableDescr + let keys = if keyCols == [] + then if ks /= [] then map Key ks else [Key $ map (\(Column n' _) -> n') cols] + else error $ "The following columns were used as key but not a column of table " ++ n ++ " : " ++ show keyCols let table' = Table ([] :=> tTy) n cols keys let pattern = [prefixVar fv] let nameType = map (\(Column name t) -> (name, t)) cols @@ -245,81 +250,85 @@ return expr where legalType :: String -> String -> String -> FType -> (FType -> Bool) -> Bool - legalType tn cn nr t f = case f t of - True -> True - False -> error $ "The type: " ++ show t ++ "\nis not compatible with the type of column nr: " ++ nr - ++ " namely: " ++ cn ++ "\n in table " ++ tn ++ "." -transformE (LamE _ _) = $impossible + legalType tn cn nr t f = f t || error ( "The type: " + ++ show t + ++ "\nis not compatible with the type of column nr: " ++ nr + ++ " namely: " ++ cn ++ "\n in table " ++ tn ++ ".") +transformE (LamE _) = $impossible --- | Transform a function argument -transformArg :: IConnection conn => Exp -> N conn Param -transformArg (LamE f ty) = do - n <- freshVar - let (ArrowT t1 _) = ty - let fty = transformTy ty - let e1 = f $ VarE n t1 - case e1 of - l@(LamE _ _) -> do - (ParAbstr _ vs e') <- transformArg l - return $ ParAbstr ([] :=> fty) ((prefixVar n):vs) e' - _ -> ParAbstr ([] :=> fty) [prefixVar n] <$> transformE e1 -transformArg e = (\e' -> ParExpr (typeOf e') e') <$> transformE e +transformLamArg :: forall a b conn. (IConnection conn) => Exp (a -> b) -> N conn Param +transformLamArg (LamE f) = do + let ty = reify (undefined :: a -> b) + n <- freshVar + let fty = transformTy ty + let e1 = f $ VarE $ fromIntegral n + ParAbstr ([] :=> fty) [prefixVar n] <$> transformE e1 +transformLamArg (AppE _ _) = $impossible +transformLamArg (VarE _) = $impossible + +transformArg :: (IConnection conn,Reify a) => Exp a -> N conn Param +transformArg e = (\e' -> ParExpr (typeOf e') e') <$> transformE e + -- | Construct a flat-FerryCore type out of a DSH type -- A flat type consists out of two tuples, a record is translated as: -- {r1 :: t1, r2 :: t2, r3 :: t3, r4 :: t4} (t1, (t2, (t3, t4))) -flatFTy :: Type -> FType +flatFTy :: Type a -> FType flatFTy (ListT t) = FList $ FRec $ flatFTy' 1 t where - flatFTy' :: Int -> Type -> [(RLabel, FType)] - flatFTy' i (TupleT t1 t2) = (RLabel $ show i, transformTy t1) : (flatFTy' (i + 1) t2) - flatFTy' i ty = [(RLabel $ show i, transformTy ty)] + flatFTy' :: Int -> Type a -> [(RLabel, FType)] + flatFTy' i (PairT t1 t2) = (RLabel $ show i, transformTy t1) : flatFTy' (i + 1) t2 + flatFTy' i ty = [(RLabel $ show i, transformTy ty)] flatFTy _ = $impossible -- Determine the size of a flat type -sizeOfTy :: Type -> Int -sizeOfTy (TupleT _ t2) = 1 + sizeOfTy t2 +sizeOfTy :: Type a -> Int +sizeOfTy (PairT _ t2) = 1 + sizeOfTy t2 sizeOfTy _ = 1 -- | Transform an arbitrary DSH-type into a ferry core type -transformTy :: Type -> FType +transformTy :: Type a -> FType transformTy UnitT = int transformTy BoolT = bool transformTy CharT = string transformTy TextT = string transformTy IntegerT = int transformTy DoubleT = float -transformTy (TupleT t1 t2) = FRec [(RLabel "1", transformTy t1), (RLabel "2", transformTy t2)] +transformTy (PairT t1 t2) = FRec [(RLabel "1", transformTy t1), (RLabel "2", transformTy t2)] transformTy (ListT t1) = FList $ transformTy t1 -transformTy (ArrowT t1 t2) = (transformTy t1) .-> (transformTy t2) +transformTy (ArrowT t1 t2) = transformTy t1 .-> transformTy t2 --- | Transform a ferry-core type into a DSH-type -transformTy' :: FType -> Type -transformTy' FUnit = UnitT -transformTy' FInt = IntegerT -transformTy' FFloat = DoubleT -transformTy' FString = TextT -transformTy' FBool = BoolT -transformTy' (FList t) = ListT $ transformTy' t -transformTy' (FRec [(RLabel "1", t1), (RLabel "2", t2)]) = TupleT (transformTy' t1) (transformTy' t2) -transformTy' (FFn t1 t2) = ArrowT (transformTy' t1) (transformTy' t2) -transformTy' _ = $impossible +isOp :: Fun a b -> Bool +isOp Add = True +isOp Sub = True +isOp Mul = True +isOp Div = True +isOp Equ = True +isOp Lt = True +isOp Lte = True +isOp Gte = True +isOp Gt = True +isOp Conj = True +isOp Disj = True +isOp _ = False + -- | Translate the DSH operator to Ferry Core operators -transformOp :: Fun2 -> Op -transformOp Add = Op "+" -transformOp Sub = Op "-" -transformOp Mul = Op "*" -transformOp Div = Op "/" -transformOp Equ = Op "==" -transformOp Lt = Op "<" -transformOp Lte = Op "<=" -transformOp Gte = Op ">=" -transformOp Gt = Op ">" +transformOp :: Fun a b -> Op +transformOp Add = Op "+" +transformOp Sub = Op "-" +transformOp Mul = Op "*" +transformOp Div = Op "/" +transformOp Equ = Op "==" +transformOp Lt = Op "<" +transformOp Lte = Op "<=" +transformOp Gte = Op ">=" +transformOp Gt = Op ">" transformOp Conj = Op "&&" transformOp Disj = Op "||" -transformOp _ = $impossible +transformOp _ = $impossible + -- | Transform a DSH-primitive-function (f) with an instantiated typed into a FerryCore -- expression transformF :: (Show f) => f -> FType -> CoreExpr @@ -327,32 +336,21 @@ (x:xs) -> toLower x : xs _ -> $impossible) $ show f --- | Retrieve all DB-table names from a DSH program -getTableNames :: Exp -> [String] -getTableNames e = let tables = map (\t -> case t of - (TableE (TableDB n _) _) -> n - _ -> $impossible) $ listify isTable e - in nub tables - where - isTable :: Exp -> Bool - isTable (TableE (TableDB _ _) _) = True - isTable _ = False - -- | Retrieve through the given database connection information on the table (columns with their types) -- which name is given as the second argument. -getTableInfo :: IConnection conn => conn -> String -> IO [(String, (FType -> Bool))] +getTableInfo :: IConnection conn => conn -> String -> IO [(String,FType -> Bool)] getTableInfo c n = do info <- describeTable c n return $ toTableDescr info where - toTableDescr :: [(String, SqlColDesc)] -> [(String, (FType -> Bool))] + toTableDescr :: [(String, SqlColDesc)] -> [(String,FType -> Bool)] toTableDescr = L.sortBy (\(n1, _) (n2, _) -> compare n1 n2) . map (\(name, props) -> (name, compatibleType (colType props))) compatibleType :: SqlTypeId -> FType -> Bool compatibleType dbT hsT = case hsT of - FUnit -> True - FBool -> L.elem dbT [SqlSmallIntT, SqlIntegerT, SqlBitT] - FString -> L.elem dbT [SqlCharT, SqlWCharT, SqlVarCharT] - FInt -> L.elem dbT [SqlSmallIntT, SqlIntegerT, SqlTinyIntT, SqlBigIntT, SqlNumericT] - FFloat -> L.elem dbT [SqlDecimalT, SqlRealT, SqlFloatT, SqlDoubleT] + FUnit -> True + FBool -> dbT `L.elem` [SqlSmallIntT, SqlIntegerT, SqlBitT] + FString -> dbT `L.elem` [SqlCharT, SqlWCharT, SqlVarCharT] + FInt -> dbT `L.elem` [SqlSmallIntT, SqlIntegerT, SqlTinyIntT, SqlBigIntT, SqlNumericT] + FFloat -> dbT `L.elem` [SqlDecimalT, SqlRealT, SqlFloatT, SqlDoubleT] t -> error $ "You can't store this kind of data in a table... " ++ show t ++ " " ++ show n diff --git a/src/Database/DSH/Data.hs b/src/Database/DSH/Data.hs deleted file mode 100644 --- a/src/Database/DSH/Data.hs +++ /dev/null @@ -1,463 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ViewPatterns, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, DeriveDataTypeable #-} - -module Database.DSH.Data where - -import Database.DSH.Impossible - -import Data.Convertible -import Data.Typeable -import Database.HDBC -import Data.Generics -import Data.Text(Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - -import GHC.Exts - -data Exp = - UnitE Type - | BoolE Bool Type - | CharE Char Type - | IntegerE Integer Type - | DoubleE Double Type - | TextE Text Type - | TupleE Exp Exp Type - | ListE [Exp] Type - | LamE (Exp -> Exp) Type - | AppE1 Fun1 Exp Type - | AppE2 Fun2 Exp Exp Type - | AppE3 Fun3 Exp Exp Exp Type - | TableE Table Type - | VarE Int Type - deriving (Show, Data, Typeable) - -instance Show (Exp -> Exp) where - show _ = "(f :: Exp -> Exp)" - -data Fun1 = - Fst | Snd | Not | IntegerToDouble - | Head | Tail | Unzip | Minimum - | Maximum | Concat | Sum | And - | Or | Reverse | Length | Null | Init - | Last | The | Nub - deriving (Eq, Ord, Show, Data, Typeable) - - -data Fun2 = - Add | Mul | Sub | Div | All | Any | Index - | SortWith | Cons | Snoc | Take | Drop - | Map | Append | Filter | GroupWith | Zip - | Break | Span | DropWhile | TakeWhile - | SplitAt | Equ | Conj | Disj - | Lt | Lte | Gte | Gt | Max | Min - deriving (Eq, Ord, Show, Data, Typeable) - -data Fun3 = Cond | ZipWith - deriving (Eq, Ord, Show, Data, Typeable) - - -data Norm = - UnitN Type - | BoolN Bool Type - | CharN Char Type - | IntegerN Integer Type - | DoubleN Double Type - | TextN Text Type - | TupleN Norm Norm Type - | ListN [Norm] Type - deriving (Eq, Ord, Show, Data, Typeable) - -data Type = - UnitT - | BoolT - | CharT - | IntegerT - | DoubleT - | TextT - | TupleT Type Type - | ListT Type - | ArrowT Type Type - deriving (Eq, Ord, Show, Data, Typeable) - - -data Table = - TableDB String [[String]] - | TableCSV String - deriving (Eq, Ord, Show, Data, Typeable) - - -typeExp :: Exp -> Type -typeExp e = case e of - UnitE t -> t - BoolE _ t -> t - CharE _ t -> t - IntegerE _ t -> t - DoubleE _ t -> t - TextE _ t -> t - TupleE _ _ t -> t - ListE _ t -> t - LamE _ t -> t - AppE1 _ _ t -> t - AppE2 _ _ _ t -> t - AppE3 _ _ _ _ t -> t - TableE _ t -> t - VarE _ t -> t - -typeArrowResult :: Type -> Type -typeArrowResult (ArrowT _ t) = t -typeArrowResult _ = $impossible - -typeTupleFst :: Type -> Type -typeTupleFst (TupleT a _) = a -typeTupleFst _ = $impossible - -typeTupleSnd :: Type -> Type -typeTupleSnd (TupleT _ b) = b -typeTupleSnd _ = $impossible - -typeNorm :: Norm -> Type -typeNorm = typeExp . convert - -data Q a = Q Exp deriving (Show, Data, Typeable) - -class QA a where - reify :: a -> Type - toNorm :: a -> Norm - fromNorm :: Norm -> a - -instance QA () where - reify _ = UnitT - toNorm _ = UnitN UnitT - fromNorm (UnitN UnitT) = () - fromNorm _ = $impossible - -instance QA Bool where - reify _ = BoolT - toNorm b = BoolN b BoolT - fromNorm (BoolN b BoolT) = b - fromNorm v = $impossible - -instance QA Char where - reify _ = CharT - toNorm c = CharN c CharT - fromNorm (CharN c CharT) = c - fromNorm _ = $impossible - -instance QA Integer where - reify _ = IntegerT - toNorm i = IntegerN i IntegerT - fromNorm (IntegerN i IntegerT) = i - fromNorm _ = $impossible - -instance QA Double where - reify _ = DoubleT - toNorm d = DoubleN d DoubleT - fromNorm (DoubleN i DoubleT) = i - fromNorm _ = $impossible - -instance QA Text where - reify _ = TextT - toNorm t = TextN t TextT - fromNorm (TextN t TextT) = t - fromNorm _ = $impossible - -instance (QA a,QA b) => QA (a,b) where - reify _ = TupleT (reify (undefined :: a)) (reify (undefined :: b)) - toNorm (a,b) = TupleN (toNorm a) (toNorm b) (reify (a,b)) - fromNorm (TupleN a b (TupleT _ _)) = (fromNorm a,fromNorm b) - fromNorm _ = $impossible - -instance (QA a) => QA [a] where - reify _ = ListT (reify (undefined :: a)) - toNorm as = ListN (map toNorm as) (reify as) - fromNorm (ListN as (ListT _)) = map fromNorm as - fromNorm _ = $impossible - -instance (QA a) => QA (Maybe a) where - reify _ = reify ([] :: [a]) - - toNorm Nothing = toNorm ([] :: [a]) - toNorm (Just x) = toNorm [x] - - fromNorm ma = case (fromNorm ma) :: [a] of - [] -> Nothing - (x : _) -> Just x - -instance (QA a,QA b) => QA (Either a b) where - reify _ = reify (([],[]) :: ([a],[b])) - - toNorm (Left x) = toNorm ([x],[] :: [b]) - toNorm (Right x) = toNorm ([] :: [a],[x]) - - fromNorm e = case (fromNorm e) :: ([a],[b]) of - ([],x : _) -> Right x - (x : _,[]) -> Left x - _ -> $impossible - - -tupleToEither :: (QA a,QA b) => Q ([a],[b]) -> Q (Either a b) -tupleToEither (Q x) = (Q x) - -eitherToTuple :: (QA a,QA b) => Q (Either a b) -> Q ([a],[b]) -eitherToTuple (Q x) = (Q x) - -class BasicType a where - -instance BasicType () where -instance BasicType Bool where -instance BasicType Char where -instance BasicType Integer where -instance BasicType Double where -instance BasicType Text where - --- * Refering to Real Database Tables - -class (QA a) => TA a where - tablePersistence :: Table -> Q [a] - tablePersistence t = Q (TableE t (reify (undefined :: [a]))) - - -table :: (TA a) => String -> Q [a] -table = tableDB - -tableDB :: (TA a) => String -> Q [a] -tableDB name = tablePersistence (TableDB name []) - -tableWithKeys :: (TA a) => String -> [[String]] -> Q [a] -tableWithKeys name keys = tablePersistence (TableDB name keys) - -tableCSV :: (TA a) => String -> Q [a] -tableCSV filename = tablePersistence (TableCSV filename) - - -instance TA () where -instance TA Bool where -instance TA Char where -instance TA Integer where -instance TA Double where -instance TA Text where -instance (BasicType a, BasicType b, QA a, QA b) => TA (a,b) where - --- * Eq, Ord and Num Instances for Databse Queries - -instance Eq (Q Integer) where - (==) _ _ = error "Eq instance for (Q Integer) must not be used." - -instance Eq (Q Double) where - (==) _ _ = error "Eq instance for (Q Double) must not be used." - -instance Num (Q Integer) where - (+) (Q e1) (Q e2) = Q (AppE2 Add e1 e2 IntegerT) - (*) (Q e1) (Q e2) = Q (AppE2 Mul e1 e2 IntegerT) - (-) (Q e1) (Q e2) = Q (AppE2 Sub e1 e2 IntegerT) - - fromInteger i = Q (IntegerE i IntegerT) - - abs (Q e1) = - let zero = IntegerE 0 IntegerT - e1Negated = AppE2 Sub zero e1 IntegerT - in Q (AppE3 Cond (AppE2 Lt e1 zero BoolT) e1Negated e1 IntegerT) - - signum (Q e1) = - let zero = IntegerE 0 IntegerT - one = IntegerE 1 IntegerT - minusOne = IntegerE (negate 1) IntegerT - in Q (AppE3 Cond (AppE2 Lt e1 zero BoolT) - (minusOne) - (AppE3 Cond (AppE2 Equ e1 zero BoolT) zero one IntegerT) - IntegerT) - -instance Num (Q Double) where - (+) (Q e1) (Q e2) = Q (AppE2 Add e1 e2 DoubleT) - (*) (Q e1) (Q e2) = Q (AppE2 Mul e1 e2 DoubleT) - (-) (Q e1) (Q e2) = Q (AppE2 Sub e1 e2 DoubleT) - - fromInteger d = Q (DoubleE (fromIntegral d) DoubleT) - - abs (Q e1) = - let zero = DoubleE 0.0 DoubleT - e1Negated = AppE2 Sub zero e1 DoubleT - in Q (AppE3 Cond (AppE2 Lt e1 zero BoolT) e1Negated e1 DoubleT) - - signum (Q e1) = - let zero = DoubleE 0.0 DoubleT - one = DoubleE 1.0 DoubleT - minusOne = DoubleE (negate 1.0) DoubleT - in Q (AppE3 Cond (AppE2 Lt e1 zero BoolT) - (minusOne) - (AppE3 Cond (AppE2 Equ e1 zero BoolT) zero one DoubleT) - DoubleT) - - -instance Fractional (Q Double) where - (/) (Q e1) (Q e2) = Q (AppE2 Div e1 e2 DoubleT) - fromRational r = Q (DoubleE (fromRational r) DoubleT) - --- * Support for View Patterns - -class View a b | a -> b, b -> a where - view :: a -> b - fromView :: b -> a - -tuple :: (View a b) => b -> a -tuple = fromView - -record :: (View a b) => b -> a -record = fromView - -instance View (Q ()) (Q ()) where - view = id - fromView = id - -instance View (Q Bool) (Q Bool) where - view = id - fromView = id - -instance View (Q Char) (Q Char) where - view = id - fromView = id - -instance View (Q Integer) (Q Integer) where - view = id - fromView = id - -instance View (Q Double) (Q Double) where - view = id - fromView = id - -instance View (Q Text) (Q Text) where - view = id - fromView = id - -instance (QA a,QA b) => View (Q (a,b)) (Q a, Q b) where - view (Q a) = (Q (AppE1 Fst a (reify (undefined :: a))), Q (AppE1 Snd a (reify (undefined :: b)))) - fromView ((Q e1),(Q e2)) = Q (TupleE e1 e2 (reify (undefined :: (a, b)))) - -instance Convertible Norm Exp where - safeConvert n = Right $ - case n of - UnitN t -> UnitE t - BoolN b t -> BoolE b t - CharN c t -> CharE c t - TextN s t -> TextE s t - IntegerN i t -> IntegerE i t - DoubleN d t -> DoubleE d t - TupleN n1 n2 t -> TupleE (convert n1) (convert n2) t - ListN ns t -> ListE (map convert ns) t - -forget :: (QA a) => Q a -> Exp -forget (Q a) = a - -toLam1 :: forall a b. (QA a,QA b) => (Q a -> Q b) -> Exp -toLam1 f = LamE (forget . f . Q) (ArrowT (reify (undefined :: a)) (reify (undefined :: b))) - -toLam2 :: forall a b c. (QA a,QA b,QA c) => (Q a -> Q b -> Q c) -> Exp -toLam2 f = - let f1 = \a b -> forget (f (Q a) (Q b)) - t1 = ArrowT (reify (undefined :: b)) (reify (undefined :: c)) - f2 = \a -> LamE (\b -> f1 a b) t1 - t2 = ArrowT (reify (undefined :: a)) t1 - in LamE f2 t2 - -unfoldType :: Type -> [Type] -unfoldType (TupleT t1 t2) = t1 : unfoldType t2 -unfoldType t = [t] - -instance Convertible Type SqlTypeId where - safeConvert n = - case n of - IntegerT -> Right SqlBigIntT - DoubleT -> Right SqlDoubleT - BoolT -> Right SqlBitT - CharT -> Right SqlCharT - TextT -> Right SqlVarCharT - UnitT -> convError "No `UnitT' representation" n - TupleT {} -> convError "No `TupleT' representation" n - ListT {} -> convError "No `ListT' representation" n - ArrowT {} -> convError "No `ArrowT' representation" n - -instance Convertible SqlTypeId Type where - safeConvert n = - case n of - SqlCharT -> Right TextT - SqlVarCharT -> Right TextT - SqlLongVarCharT -> Right TextT - SqlWCharT -> Right TextT - SqlWVarCharT -> Right TextT - SqlWLongVarCharT -> Right TextT - SqlDecimalT -> Right DoubleT - SqlNumericT -> Right DoubleT - SqlSmallIntT -> Right IntegerT - SqlIntegerT -> Right IntegerT - SqlRealT -> Right DoubleT - SqlFloatT -> Right DoubleT - SqlDoubleT -> Right DoubleT - SqlBitT -> Right BoolT - SqlBigIntT -> Right IntegerT - SqlTinyIntT -> Right IntegerT - _ -> convError "Unsupported `SqlTypeId'" n - - -instance Convertible SqlValue Norm where - safeConvert sql = - case sql of - SqlNull -> Right $ UnitN UnitT - SqlInteger i -> Right $ IntegerN i IntegerT - SqlDouble d -> Right $ DoubleN d DoubleT - SqlBool b -> Right $ BoolN b BoolT - SqlChar c -> Right $ CharN c CharT - SqlString t -> Right $ TextN (T.pack t) TextT - SqlByteString s -> Right $ TextN (T.decodeUtf8 s) TextT - _ -> convError "Unsupported `SqlValue'" sql - -instance Convertible (SqlValue, Type) Norm where - safeConvert sql = - case sql of - (SqlNull, UnitT) -> Right $ UnitN UnitT - - (SqlInteger i, IntegerT) -> Right $ IntegerN i IntegerT - (SqlInt32 i, IntegerT) -> Right $ flip IntegerN IntegerT $ convert i - (SqlInt64 i, IntegerT) -> Right $ flip IntegerN IntegerT $ convert i - (SqlWord32 i, IntegerT) -> Right $ flip IntegerN IntegerT $ convert i - (SqlWord64 i, IntegerT) -> Right $ flip IntegerN IntegerT $ convert i - (SqlRational r, IntegerT) -> Right $ flip IntegerN IntegerT $ convert r - - (SqlDouble d, DoubleT) -> Right $ DoubleN d DoubleT - (SqlRational r, DoubleT) -> Right $ flip DoubleN DoubleT $ convert r - (SqlInteger i, DoubleT) -> Right $ flip DoubleN DoubleT $ convert i - (SqlInt32 i, DoubleT) -> Right $ flip DoubleN DoubleT $ convert i - (SqlInt64 i, DoubleT) -> Right $ flip DoubleN DoubleT $ convert i - (SqlWord32 i, DoubleT) -> Right $ flip DoubleN DoubleT $ convert i - (SqlWord64 i, DoubleT) -> Right $ flip DoubleN DoubleT $ convert i - - (SqlBool b, BoolT) -> Right $ BoolN b BoolT - (SqlInteger i, BoolT) -> Right $ BoolN (i == 1) BoolT - (SqlInt32 i, BoolT) -> Right $ BoolN (i == 1) BoolT - (SqlInt64 i, BoolT) -> Right $ BoolN (i == 1) BoolT - (SqlWord32 i, BoolT) -> Right $ BoolN (i == 1) BoolT - (SqlWord64 i, BoolT) -> Right $ BoolN (i == 1) BoolT - - (SqlString s, TextT) -> Right $ TextN (T.pack s) TextT - (SqlByteString s, TextT) -> Right $ TextN (T.decodeUtf8 s) TextT - - (SqlChar c, CharT) -> Right $ CharN c CharT - (SqlString (c : _), CharT) -> Right $ CharN c CharT - (SqlByteString ((T.unpack . T.decodeUtf8) -> (c : _)), CharT) -> Right $ CharN c CharT - - _ -> $impossible - -instance Convertible Norm SqlValue where - safeConvert n = - case n of - UnitN _ -> Right $ SqlNull - IntegerN i _ -> Right $ SqlInteger i - DoubleN d _ -> Right $ SqlDouble d - BoolN b _ -> Right $ SqlBool b - CharN c _ -> Right $ SqlChar c - TextN t _ -> Right $ SqlString $ T.unpack t - ListN _ _ -> convError "Cannot convert `Norm' to `SqlValue'" n - TupleN _ _ _ -> convError "Cannot convert `Norm' to `SqlValue'" n - - -instance IsString (Q Text) where - fromString s = Q (TextE (T.pack s) TextT) diff --git a/src/Database/DSH/Externals.hs b/src/Database/DSH/Externals.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Externals.hs @@ -0,0 +1,647 @@ +module Database.DSH.Externals where + +import Database.DSH.Internals +import Database.DSH.Impossible +import Database.DSH.TH + +import Prelude ( Eq, Ord, Num(..), Fractional(..), Show(..) + , Bool(..), Char, Integer, Double, String, Maybe(..), Either(..) + , id, undefined, ($), (.)) +import qualified Prelude as P + +import Data.String +import Data.Text (Text) +import qualified Data.Text as T + +-- QA Instances + +instance QA () where + type Rep () = () + toExp () = UnitE + frExp UnitE = () + frExp _ = $impossible + +instance QA Bool where + type Rep Bool = Bool + toExp = BoolE + frExp (BoolE b) = b + frExp _ = $impossible + +instance QA Char where + type Rep Char = Char + toExp = CharE + frExp (CharE c) = c + frExp _ = $impossible + +instance QA Integer where + type Rep Integer = Integer + toExp = IntegerE + frExp (IntegerE i) = i + frExp _ = $impossible + +instance QA Double where + type Rep Double = Double + toExp = DoubleE + frExp (DoubleE d) = d + frExp _ = $impossible + +instance QA Text where + type Rep Text = Text + toExp = TextE + frExp (TextE t) = t + frExp _ = $impossible + +instance (QA a, QA b) => QA (a,b) where + type Rep (a,b) = (Rep a,Rep b) + toExp (a,b) = PairE (toExp a) (toExp b) + frExp (PairE a b) = (frExp a,frExp b) + frExp _ = $impossible + +instance (QA a) => QA [a] where + type Rep [a] = [Rep a] + toExp as = ListE (P.map toExp as) + frExp (ListE as) = P.map frExp as + frExp _ = $impossible + +instance (QA a) => QA (Maybe a) where + type Rep (Maybe a) = [Rep a] + toExp Nothing = ListE [] + toExp (Just a) = ListE [toExp a] + frExp (ListE []) = Nothing + frExp (ListE (a : _)) = Just (frExp a) + frExp _ = $impossible + +instance (QA a,QA b) => QA (Either a b) where + type Rep (Either a b) = ([Rep a],[Rep b]) + toExp (Left a) = PairE (ListE [toExp a]) (ListE []) + toExp (Right b) = PairE (ListE []) (ListE [toExp b]) + frExp (PairE (ListE (a : _)) _) = Left (frExp a) + frExp (PairE _ (ListE (a : _))) = Right (frExp a) + frExp _ = $impossible + +-- Elim instances + +instance (QA r) => Elim () r where + type Eliminator () r = Q r -> Q r + elim _ r = r + +instance (QA r) => Elim Bool r where + type Eliminator Bool r = Q r -> Q r -> Q r + elim (Q e) (Q e1) (Q e2) = Q (AppE Cond (PairE e (PairE e1 e2))) + +instance (QA r) => Elim Char r where + type Eliminator Char r = (Q Char -> Q r) -> Q r + elim q f = f q + +instance (QA r) => Elim Integer r where + type Eliminator Integer r = (Q Integer -> Q r) -> Q r + elim q f = f q + +instance (QA r) => Elim Double r where + type Eliminator Double r = (Q Double -> Q r) -> Q r + elim q f = f q + +instance (QA r) => Elim Text r where + type Eliminator Text r = (Q Text -> Q r) -> Q r + elim q f = f q + +instance (QA a,QA b,QA r) => Elim (a,b) r where + type Eliminator (a,b) r = (Q a -> Q b -> Q r) -> Q r + elim q f = f (fst q) (snd q) + +instance (QA a,QA r) => Elim (Maybe a) r where + type Eliminator (Maybe a) r = Q r -> (Q a -> Q r) -> Q r + elim q r f = maybe r f q + +instance (QA a,QA b,QA r) => Elim (Either a b) r where + type Eliminator (Either a b) r = (Q a -> Q r) -> (Q b -> Q r) -> Q r + elim q f g = either f g q + +-- BasicType instances + +instance BasicType () where +instance BasicType Bool where +instance BasicType Char where +instance BasicType Integer where +instance BasicType Double where +instance BasicType Text where + +-- TA instances + +instance TA () where +instance TA Bool where +instance TA Char where +instance TA Integer where +instance TA Double where +instance TA Text where +instance (BasicType a, BasicType b) => TA (a,b) where + +-- Num and Fractional instances + +instance Num (Exp Integer) where + (+) e1 e2 = AppE Add (PairE e1 e2) + (*) e1 e2 = AppE Mul (PairE e1 e2) + (-) e1 e2 = AppE Sub (PairE e1 e2) + + fromInteger = IntegerE + + abs e = let c = AppE Lt (PairE e 0) + in AppE Cond (PairE c (PairE (negate e) e)) + + signum e = let c1 = AppE Lt (PairE e 0) + c2 = AppE Equ (PairE e 0) + e' = AppE Cond (PairE c2 (PairE 0 1)) + in AppE Cond (PairE c1 (PairE (-1) e')) + +instance Num (Exp Double) where + (+) e1 e2 = AppE Add (PairE e1 e2) + (*) e1 e2 = AppE Mul (PairE e1 e2) + (-) e1 e2 = AppE Sub (PairE e1 e2) + + fromInteger = DoubleE . fromInteger + + abs e = let c = AppE Lt (PairE e 0) + in AppE Cond (PairE c (PairE (negate e) e)) + + signum e = let c1 = AppE Lt (PairE e 0.0) + c2 = AppE Equ (PairE e 0.0) + e' = AppE Cond (PairE c2 (PairE 0 1)) + in AppE Cond (PairE c1 (PairE (-1) e')) + +instance Fractional (Exp Double) where + (/) e1 e2 = AppE Div (PairE e1 e2) + fromRational = DoubleE . fromRational + +instance Num (Q Integer) where + (+) (Q e1) (Q e2) = Q (e1 + e2) + (*) (Q e1) (Q e2) = Q (e1 * e2) + (-) (Q e1) (Q e2) = Q (e1 - e2) + fromInteger = Q . IntegerE + abs (Q e) = Q (abs e) + signum (Q e) = Q (signum e) + +instance Num (Q Double) where + (+) (Q e1) (Q e2) = Q (e1 + e2) + (*) (Q e1) (Q e2) = Q (e1 * e2) + (-) (Q e1) (Q e2) = Q (e1 - e2) + fromInteger = Q . DoubleE . fromInteger + abs (Q e) = Q (abs e) + signum (Q e) = Q (signum e) + +instance Fractional (Q Double) where + (/) (Q e1) (Q e2) = Q (e1 / e2) + fromRational = Q . DoubleE . fromRational + +-- View instances + +instance View (Q ()) (Q ()) where + type ToView (Q ()) = Q () + type FromView (Q ()) = Q () + view = id + fromView = id + +instance View (Q Bool) (Q Bool) where + type ToView (Q Bool) = Q Bool + type FromView (Q Bool) = Q Bool + view = id + fromView = id + +instance View (Q Char) (Q Char) where + type ToView (Q Char) = Q Char + type FromView (Q Char) = Q Char + view = id + fromView = id + +instance View (Q Integer) (Q Integer) where + type ToView (Q Integer) = Q Integer + type FromView (Q Integer) = Q Integer + view = id + fromView = id + +instance View (Q Double) (Q Double) where + type ToView (Q Double) = Q Double + type FromView (Q Double) = Q Double + view = id + fromView = id + +instance View (Q Text) (Q Text) where + type ToView (Q Text) = Q Text + type FromView (Q Text) = Q Text + view = id + fromView = id + +instance (QA a, QA b) => View (Q (a,b)) (Q a,Q b) where + type ToView (Q (a,b)) = (Q a,Q b) + type FromView (Q a,Q b) = (Q (a,b)) + view (Q e) = (Q (AppE Fst e),Q (AppE Snd e)) + fromView (Q a,Q b) = Q (PairE a b) + +-- IsString instances + +instance IsString (Q Text) where + fromString = Q . TextE . T.pack + +-- * Referring to persistent tables + +table :: (QA a, TA a) => String -> Q [a] +table name = Q (TableE (TableDB name [])) + +tableDB :: (QA a, TA a) => String -> Q [a] +tableDB name = Q (TableE (TableDB name [])) + +tableWithKeys :: (QA a, TA a) => String -> [[String]] -> Q [a] +tableWithKeys name keys = Q (TableE (TableDB name keys)) + +tableCSV :: (QA a, TA a) => String -> Q [a] +tableCSV filename = Q (TableE (TableCSV filename)) + +-- * toQ + +toQ :: (QA a) => a -> Q a +toQ = Q . toExp + +-- * Unit + +unit :: Q () +unit = Q UnitE + +-- * Boolean logic + +false :: Q Bool +false = Q (BoolE False) + +true :: Q Bool +true = Q (BoolE True) + +not :: Q Bool -> Q Bool +not (Q e) = Q (AppE Not e) + +(&&) :: Q Bool -> Q Bool -> Q Bool +(&&) (Q a) (Q b) = Q (AppE Conj (PairE a b)) + +(||) :: Q Bool -> Q Bool -> Q Bool +(||) (Q a) (Q b) = Q (AppE Disj (PairE a b)) + +-- * Equality and Ordering + +eq :: (QA a,Eq a) => Q a -> Q a -> Q Bool +eq (Q a) (Q b) = Q (AppE Equ (PairE a b)) + +(==) :: (QA a,Eq a) => Q a -> Q a -> Q Bool +(==) = eq + +neq :: (QA a,Eq a) => Q a -> Q a -> Q Bool +neq a b = not (eq a b) + +(/=) :: (QA a,Eq a) => Q a -> Q a -> Q Bool +(/=) = neq + +lt :: (QA a,Ord a) => Q a -> Q a -> Q Bool +lt (Q a) (Q b) = Q (AppE Lt (PairE a b)) + +(<) :: (QA a,Ord a) => Q a -> Q a -> Q Bool +(<) = lt + +lte :: (QA a,Ord a) => Q a -> Q a -> Q Bool +lte (Q a) (Q b) = Q (AppE Lte (PairE a b)) + +(<=) :: (QA a,Ord a) => Q a -> Q a -> Q Bool +(<=) = lte + +gte :: (QA a,Ord a) => Q a -> Q a -> Q Bool +gte (Q a) (Q b) = Q (AppE Gte (PairE a b)) + +(>=) :: (QA a,Ord a) => Q a -> Q a -> Q Bool +(>=) = gte + +gt :: (QA a,Ord a) => Q a -> Q a -> Q Bool +gt (Q a) (Q b) = Q (AppE Gt (PairE a b)) + +(>) :: (QA a,Ord a) => Q a -> Q a -> Q Bool +(>) = gt + +min :: (QA a,Ord a) => Q a -> Q a -> Q a +min (Q a) (Q b) = Q (AppE Min (PairE a b)) + +max :: (QA a,Ord a) => Q a -> Q a -> Q a +max (Q a) (Q b) = Q (AppE Max (PairE a b)) + +-- * Conditionals + +bool :: (QA a) => Q a -> Q a -> Q Bool -> Q a +bool f t b = cond b t f + +cond :: (QA a) => Q Bool -> Q a -> Q a -> Q a +cond (Q c) (Q a) (Q b) = Q (AppE Cond (PairE c (PairE a b))) + +(?) :: (QA a) => Q Bool -> (Q a,Q a) -> Q a +(?) c (a,b) = cond c a b + +-- * Maybe + +listToMaybe :: (QA a) => Q [a] -> Q (Maybe a) +listToMaybe (Q as) = Q as + +maybeToList :: (QA a) => Q (Maybe a) -> Q [a] +maybeToList (Q ma) = Q ma + +nothing :: (QA a) => Q (Maybe a) +nothing = listToMaybe nil + +just :: (QA a) => Q a -> Q (Maybe a) +just a = listToMaybe (singleton a) + +isNothing :: (QA a) => Q (Maybe a) -> Q Bool +isNothing ma = null (maybeToList ma) + +isJust :: (QA a) => Q (Maybe a) -> Q Bool +isJust ma = not (isNothing ma) + +fromJust :: (QA a) => Q (Maybe a) -> Q a +fromJust ma = head (maybeToList ma) + +maybe :: (QA a,QA b) => Q b -> (Q a -> Q b) -> Q (Maybe a) -> Q b +maybe b f ma = isNothing ma ? (b,f (fromJust ma)) + +fromMaybe :: (QA a) => Q a -> Q (Maybe a) -> Q a +fromMaybe a ma = isNothing ma ? (a,fromJust ma) + +catMaybes :: (QA a) => Q [Maybe a] -> Q [a] +catMaybes = concatMap maybeToList + +mapMaybe :: (QA a,QA b) => (Q a -> Q (Maybe b)) -> Q [a] -> Q [b] +mapMaybe f = concatMap (maybeToList . f) + +-- * Either + +pairToEither :: (QA a,QA b) => Q ([a],[b]) -> Q (Either a b) +pairToEither (Q a) = Q a + +eitherToPair :: (QA a,QA b) => Q (Either a b) -> Q ([a],[b]) +eitherToPair (Q a) = Q a + +left :: (QA a,QA b) => Q a -> Q (Either a b) +left a = pairToEither (tuple (singleton a,nil)) + +right :: (QA a,QA b) => Q b -> Q (Either a b) +right a = pairToEither (tuple (nil,singleton a)) + +isLeft :: (QA a,QA b) => Q (Either a b) -> Q Bool +isLeft = null . snd . eitherToPair + +isRight :: (QA a,QA b) => Q (Either a b) -> Q Bool +isRight = null . fst . eitherToPair + +either :: (QA a,QA b,QA c) => (Q a -> Q c) -> (Q b -> Q c) -> Q (Either a b) -> Q c +either lf rf e = isLeft e ? ((lf . head . fst . eitherToPair) e,(rf . head . snd . eitherToPair) e) + +lefts :: (QA a,QA b) => Q [Either a b] -> Q [a] +lefts = concatMap (fst . eitherToPair) + +rights :: (QA a,QA b) => Q [Either a b] -> Q [b] +rights = concatMap (snd . eitherToPair) + +partitionEithers :: (QA a,QA b) => Q [Either a b] -> Q ([a], [b]) +partitionEithers es = tuple (lefts es,rights es) + +-- * List Construction + +nil :: (QA a) => Q [a] +nil = Q (ListE []) + +empty :: (QA a) => Q [a] +empty = nil + +cons :: (QA a) => Q a -> Q [a] -> Q [a] +cons (Q a) (Q as) = Q (AppE Cons (PairE a as)) + +(<|) :: (QA a) => Q a -> Q [a] -> Q [a] +(<|) = cons + +snoc :: (QA a) => Q [a] -> Q a -> Q [a] +snoc as a = append as (singleton a) + +(|>) :: (QA a) => Q [a] -> Q a -> Q [a] +(|>) = snoc + +singleton :: (QA a) => Q a -> Q [a] +singleton (Q e) = cons (Q e) nil + +-- * List Operations + +head :: (QA a) => Q [a] -> Q a +head (Q as) = Q (AppE Head as) + +tail :: (QA a) => Q [a] -> Q [a] +tail (Q as) = Q (AppE Tail as) + +take :: (QA a) => Q Integer -> Q [a] -> Q [a] +take (Q i) (Q as) = Q (AppE Take (PairE i as)) + +drop :: (QA a) => Q Integer -> Q [a] -> Q [a] +drop (Q i) (Q as) = Q (AppE Drop (PairE i as)) + +map :: (QA a,QA b) => (Q a -> Q b) -> Q [a] -> Q [b] +map f (Q as) = Q (AppE Map (PairE (LamE (toLam f)) as)) + +append :: (QA a) => Q [a] -> Q [a] -> Q [a] +append (Q as) (Q bs) = Q (AppE Concat (ListE [as,bs])) + +(++) :: (QA a) => Q [a] -> Q [a] -> Q [a] +(++) = append + +filter :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] +filter f (Q as) = Q (AppE Filter (PairE (LamE (toLam f)) as)) + +groupWith :: (QA a,QA b,Ord b) => (Q a -> Q b) -> Q [a] -> Q [[a]] +groupWith f (Q as) = Q (AppE GroupWith (PairE (LamE (toLam f)) as)) + +sortWith :: (QA a,QA b,Ord b) => (Q a -> Q b) -> Q [a] -> Q [a] +sortWith f (Q as) = Q (AppE SortWith (PairE (LamE (toLam f)) as)) + +the :: (QA a,Eq a) => Q [a] -> Q a +the (Q as) = Q (AppE The as) + +last :: (QA a) => Q [a] -> Q a +last (Q as) = Q (AppE Last as) + +init :: (QA a) => Q [a] -> Q [a] +init (Q as) = Q (AppE Init as) + +null :: (QA a) => Q [a] -> Q Bool +null (Q as) = Q (AppE Null as) + +length :: (QA a) => Q [a] -> Q Integer +length (Q as) = Q (AppE Length as) + +index :: (QA a) => Q [a] -> Q Integer -> Q a +index (Q as) (Q i) = Q (AppE Index (PairE as i)) + +(!!) :: (QA a) => Q [a] -> Q Integer -> Q a +(!!) = index + +reverse :: (QA a) => Q [a] -> Q [a] +reverse (Q as) = Q (AppE Reverse as) + +-- * Special folds + +and :: Q [Bool] -> Q Bool +and (Q bs) = Q (AppE And bs) + +or :: Q [Bool] -> Q Bool +or (Q bs) = Q (AppE Or bs) + +any :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q Bool +any f = or . map f + +all :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q Bool +all f = and . map f + +sum :: (QA a,Num a) => Q [a] -> Q a +sum (Q as) = Q (AppE Sum as) + +concat :: (QA a) => Q [[a]] -> Q [a] +concat (Q ass) = Q (AppE Concat ass) + +concatMap :: (QA a,QA b) => (Q a -> Q [b]) -> Q [a] -> Q [b] +concatMap f as = concat (map f as) + +maximum :: (QA a,Ord a) => Q [a] -> Q a +maximum (Q as) = Q (AppE Maximum as) + +minimum :: (QA a,Ord a) => Q [a] -> Q a +minimum (Q as) = Q (AppE Minimum as) + +-- * Sublists + +splitAt :: (QA a) => Q Integer -> Q [a] -> Q ([a],[a]) +splitAt (Q i) (Q as) = Q (AppE SplitAt (PairE i as)) + +takeWhile :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] +takeWhile f (Q as) = Q (AppE TakeWhile (PairE (LamE (toLam f)) as)) + +dropWhile :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] +dropWhile f (Q as) = Q (AppE DropWhile (PairE (LamE (toLam f)) as)) + +span :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q ([a],[a]) +span f as = pair (takeWhile f as) (dropWhile f as) + +break :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q ([a],[a]) +break f = span (not . f) + +-- * Searching Lists + +elem :: (QA a,Eq a) => Q a -> Q [a] -> Q Bool +elem a as = null (filter (a ==) as) ? (false,true) + +notElem :: (QA a,Eq a) => Q a -> Q [a] -> Q Bool +notElem a as = not (a `elem` as) + +lookup :: (QA a,QA b,Eq a) => Q a -> Q [(a, b)] -> Q (Maybe b) +lookup a = listToMaybe . map snd . filter ((a ==) . fst) + +-- * Zipping and Unzipping Lists + +zip :: (QA a,QA b) => Q [a] -> Q [b] -> Q [(a,b)] +zip (Q as) (Q bs) = Q (AppE Zip (PairE as bs)) + +zipWith :: (QA a,QA b,QA c) => (Q a -> Q b -> Q c) -> Q [a] -> Q [b] -> Q [c] +zipWith f as bs = map (\e -> f (fst e) (snd e)) (zip as bs) + +unzip :: (QA a,QA b) => Q [(a,b)] -> Q ([a],[b]) +unzip (Q as) = Q (AppE Unzip as) + +-- * Set-oriented operations + +nub :: (QA a,Eq a) => Q [a] -> Q [a] +nub (Q as) = Q (AppE Nub as) + +-- * Tuple Projection Functions + +fst :: (QA a,QA b) => Q (a,b) -> Q a +fst (Q e) = Q (AppE Fst e) + +snd :: (QA a,QA b) => Q (a,b) -> Q b +snd (Q e) = Q (AppE Snd e) + +pair :: (QA a,QA b) => Q a -> Q b -> Q (a,b) +pair (Q a) (Q b) = Q (PairE a b) + +-- * Conversions between numeric types + +integerToDouble :: Q Integer -> Q Double +integerToDouble (Q i) = Q (AppE IntegerToDouble i) + +-- * Rebind Monadic Combinators + +return :: (QA a) => Q a -> Q [a] +return = singleton + +(>>=) :: (QA a,QA b) => Q [a] -> (Q a -> Q [b]) -> Q [b] +(>>=) ma f = concatMap f ma + +(>>) :: (QA a,QA b) => Q [a] -> Q [b] -> Q [b] +(>>) ma mb = concatMap (\_ -> mb) ma + +mzip :: (QA a,QA b) => Q [a] -> Q [b] -> Q [(a,b)] +mzip = zip + +guard :: Q Bool -> Q [()] +guard c = cond c (singleton unit) nil + +-- * Construction of tuples and records + +tuple :: (View a b) => b -> a +tuple = fromView + +record :: (View a b) => b -> a +record = fromView + +infixl 9 !! +infixr 5 ++, <|, |> +infix 4 ==, /=, <, <=, >=, > +infixr 3 && +infixr 2 || +infix 0 ? + +deriveTupleRangeQA 3 16 + +-- * Missing functions + +-- $missing +{- $missing + +This module offers most of the functions on lists given in PreludeList for the +'Q' type. Missing functions are: + +General folds: + +> foldl +> foldl1 +> scanl +> scanl1 +> foldr +> foldr1 +> scanr +> scanr1 + +Infinit lists: + +> iterate +> repeat +> cycle + +String functions: + +> lines +> words +> unlines +> unwords + +Zipping and unzipping lists: + +> zip3 +> zipWith3 +> unzip3 + +-} diff --git a/src/Database/DSH/Impossible.hs b/src/Database/DSH/Impossible.hs --- a/src/Database/DSH/Impossible.hs +++ b/src/Database/DSH/Impossible.hs @@ -7,4 +7,4 @@ loc <- TH.location let pos = (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc)) let message = "DSH: Impossbile happend at " ++ show pos - return (TH.AppE (TH.VarE (TH.mkName "error")) (TH.LitE (TH.StringL message))) + return (TH.AppE (TH.VarE 'error) (TH.LitE (TH.StringL message))) diff --git a/src/Database/DSH/Internals.hs b/src/Database/DSH/Internals.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Internals.hs @@ -0,0 +1,204 @@ +module Database.DSH.Internals where + +import Data.Text (Text) + +data Exp a where + UnitE :: Exp () + BoolE :: Bool -> Exp Bool + CharE :: Char -> Exp Char + IntegerE :: Integer -> Exp Integer + DoubleE :: Double -> Exp Double + TextE :: Text -> Exp Text + PairE :: (Reify a, Reify b) => Exp a -> Exp b -> Exp (a,b) + ListE :: (Reify a) => [Exp a] -> Exp [a] + AppE :: (Reify a, Reify b) => Fun a b -> Exp a -> Exp b + LamE :: (Reify a, Reify b) => (Exp a -> Exp b) -> Exp (a -> b) + VarE :: (Reify a) => Integer -> Exp a + TableE :: (Reify a) => Table -> Exp [a] + +data Table = TableDB String [[String]] | TableCSV String deriving (Eq, Ord, Show) + +data Type a where + UnitT :: Type () + BoolT :: Type Bool + CharT :: Type Char + IntegerT :: Type Integer + DoubleT :: Type Double + TextT :: Type Text + PairT :: (Reify a,Reify b) => Type a -> Type b -> Type (a,b) + ListT :: (Reify a) => Type a -> Type [a] + ArrowT :: (Reify a,Reify b) => Type a -> Type b -> Type (a -> b) + +data Fun a b where + Not :: Fun Bool Bool + IntegerToDouble :: Fun Integer Double + And :: Fun [Bool] Bool + Or :: Fun [Bool] Bool + Concat :: (Reify a) => Fun [[a]] [a] + Head :: Fun [a] a + Tail :: Fun [a] [a] + The :: Fun [a] a + Init :: Fun [a] [a] + Last :: Fun [a] a + Null :: Fun [a] Bool + Length :: Fun [a] Integer + Reverse :: Fun [a] [a] + Fst :: Fun (a,b) a + Snd :: Fun (a,b) b + Sum :: Fun [a] a + Maximum :: Fun [a] a + Minimum :: Fun [a] a + Unzip :: (Reify a,Reify b) => Fun [(a,b)] ([a],[b]) + Nub :: Fun [a] [a] + Add :: Fun (a,a) a + Mul :: Fun (a,a) a + Sub :: Fun (a,a) a + Div :: Fun (a,a) a + Lt :: Fun (a,a) Bool + Lte :: Fun (a,a) Bool + Equ :: Fun (a,a) Bool + Gte :: Fun (a,a) Bool + Gt :: Fun (a,a) Bool + Conj :: Fun (Bool,Bool) Bool + Disj :: Fun (Bool,Bool) Bool + Min :: Fun (a,a) a + Max :: Fun (a,a) a + Cons :: Fun (a,[a]) [a] + Take :: Fun (Integer,[a]) [a] + Drop :: Fun (Integer,[a]) [a] + Index :: Fun ([a],Integer) a + SplitAt :: Fun (Integer,[a]) ([a],[a]) + Zip :: Fun ([a],[b]) [(a,b)] + Map :: Fun (a -> b,[a]) [b] + Filter :: Fun (a -> Bool,[a]) [a] + GroupWith :: (Reify b) => Fun (a -> b,[a]) [[a]] + SortWith :: Fun (a -> b,[a]) [a] + TakeWhile :: Fun (a -> Bool,[a]) [a] + DropWhile :: Fun (a -> Bool,[a]) [a] + Cond :: Fun (Bool,(a,a)) a + +data Q a where + Q :: Exp (Rep a) -> Q a + +-- Classes + +class Reify a where + reify :: a -> Type a + +class (Reify (Rep a)) => QA a where + type Rep a + toExp :: a -> Exp (Rep a) + frExp :: Exp (Rep a) -> a + +class (QA a,QA r) => Elim a r where + type Eliminator a r + elim :: Q a -> Eliminator a r + +class BasicType a where + +class TA a where + +class (ToView a ~ b, FromView b ~ a) => View a b where + type ToView a + type FromView b + view :: a -> b + fromView :: b -> a + +-- Show instances + +instance Show (Type a) where + show UnitT = "()" + show BoolT = "Bool" + show CharT = "Char" + show IntegerT = "Integer" + show DoubleT = "Double" + show TextT = "Text" + show (PairT l r) = "(" ++ show l ++ ", " ++ show r ++ ")" + show (ListT t) = "[" ++ show t ++ "]" + show (ArrowT t1 t2) = "(" ++ show t1 ++ " -> " ++ show t2 ++ ")" + +instance Show (Fun a b) where + show Fst = "fst" + show Snd = "snd" + show Not = "not" + show Concat = "concat" + show Head = "head" + show Tail = "tail" + show The = "the" + show Init = "init" + show Last = "last" + show Null = "null" + show Length = "length" + show Reverse = "reverse" + show And = "and" + show Or = "or" + show Sum = "sum" + show Maximum = "maximum" + show Minimum = "minimum" + show Unzip = "unzip" + show Nub = "nub" + show IntegerToDouble = "integerToDouble" + show Add = "+" + show Mul = "*" + show Sub = "-" + show Div = "/" + show Lt = "<" + show Lte = "<=" + show Equ = "==" + show Gte = ">=" + show Gt = ">" + show Conj = "&&" + show Disj = "||" + show Min = "min" + show Max = "max" + show Cons = "cons" + show Take = "take" + show Drop = "drop" + show Index = "index" + show SplitAt = "splitAt" + show Zip = "zip" + show Map = "map" + show Filter = "filter" + show GroupWith = "groupWith" + show SortWith = "sortWith" + show TakeWhile = "takeWhile" + show DropWhile = "dropWhile" + show Cond = "cond" + +-- Reify instances + +instance Reify () where + reify _ = UnitT + +instance Reify Bool where + reify _ = BoolT + +instance Reify Char where + reify _ = CharT + +instance Reify Integer where + reify _ = IntegerT + +instance Reify Double where + reify _ = DoubleT + +instance Reify Text where + reify _ = TextT + +instance (Reify a, Reify b) => Reify (a,b) where + reify _ = PairT (reify (undefined :: a)) (reify (undefined :: b)) + +instance (Reify a) => Reify [a] where + reify _ = ListT (reify (undefined :: a)) + +instance (Reify a, Reify b) => Reify (a -> b) where + reify _ = ArrowT (reify (undefined :: a)) (reify (undefined :: b)) + + +-- Utility functions + +unQ :: Q a -> Exp (Rep a) +unQ (Q e) = e + +toLam :: (QA a,QA b) => (Q a -> Q b) -> Exp (Rep a) -> Exp (Rep b) +toLam f = unQ . f . Q diff --git a/src/Database/DSH/Interpreter.hs b/src/Database/DSH/Interpreter.hs --- a/src/Database/DSH/Interpreter.hs +++ b/src/Database/DSH/Interpreter.hs @@ -1,394 +1,385 @@ -- | This module provides the reference implementation of DSH by interpreting -- the embedded representation. -{-# LANGUAGE TemplateHaskell, ViewPatterns, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} - module Database.DSH.Interpreter (fromQ) where -import Database.DSH.Data -import Database.DSH.Impossible (impossible) -import Database.DSH.CSV (csvImport) +import Database.DSH.Internals +import Database.DSH.Impossible +import Database.DSH.CSV -import Data.Convertible +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Database.HDBC -import GHC.Exts import Data.List fromQ :: (QA a, IConnection conn) => conn -> Q a -> IO a -fromQ c (Q a) = evaluate c a >>= (return . fromNorm) +fromQ c (Q e) = fmap frExp (evaluate c e) -evaluate :: IConnection conn - => conn -- ^ The HDBC connection - -> Exp - -> IO Norm +evaluate :: forall a conn. (Reify a, IConnection conn) => conn -> Exp a -> IO (Exp a) evaluate c e = case e of - UnitE t -> return (UnitN t) - BoolE b t -> return (BoolN b t) - CharE ch t -> return (CharN ch t) - IntegerE i t -> return (IntegerN i t) - DoubleE d t -> return (DoubleN d t) - TextE s t -> return (TextN s t) - - VarE _ _ -> $impossible - LamE _ _ -> $impossible - - TupleE e1 e2 t -> do - e3 <- evaluate c e1 - e4 <- evaluate c e2 - return (TupleN e3 e4 t) - - ListE es t -> do - es1 <- mapM (evaluate c) es - return (ListN es1 t) - - AppE3 Cond cond a b _ -> do - (BoolN c1 _) <- evaluate c cond + UnitE -> return UnitE + BoolE b -> return $ BoolE b + CharE ch -> return $ CharE ch + IntegerE i -> return $ IntegerE i + DoubleE d -> return $ DoubleE d + TextE t -> return $ TextE t + VarE _ -> $impossible + LamE _ -> $impossible + PairE e1 e2 -> do + e1' <- evaluate c e1 + e2' <- evaluate c e2 + return (PairE e1' e2') + ListE es -> do + es1 <- mapM (evaluate c) es + return $ ListE es1 + AppE Cond (PairE cond (PairE a b)) -> do + (BoolE c1) <- evaluate c cond if c1 then evaluate c a else evaluate c b - - AppE2 Cons a as t -> do - a1 <- evaluate c a - (ListN as1 _) <- evaluate c as - return $ ListN (a1 : as1) t - - AppE2 Snoc as a t -> do - a1 <- evaluate c a - (ListN as1 _) <- evaluate c as - return $ ListN (snoc as1 a1) t - - AppE1 Head as _ -> do - (ListN as1 _) <- evaluate c as - return $ head as1 - - AppE1 Tail as t -> do - (ListN as1 _) <- evaluate c as - return $ ListN (tail as1) t - - AppE2 Take i as t -> do - (IntegerN i1 _) <- evaluate c i - (ListN as1 _) <- evaluate c as - return $ ListN (take (fromIntegral i1) as1) t - - AppE2 Drop i as t -> do - (IntegerN i1 _) <- evaluate c i - (ListN as1 _) <- evaluate c as - return $ ListN (drop (fromIntegral i1) as1) t - - AppE2 Map lam as t -> do - (ListN as1 _) <- evaluate c as - evaluate c $ ListE (map (evalLam lam) as1) t - - AppE2 Append as bs t -> do - (ListN as1 _) <- evaluate c as - (ListN bs1 _) <- evaluate c bs - return $ ListN (as1 ++ bs1) t - - AppE2 Filter lam as t -> do - (ListN as1 _) <- evaluate c as - (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (ListT BoolT)) - return $ ListN (map fst (filter (\(_,(BoolN b BoolT)) -> b) (zip as1 as2))) t - - AppE2 GroupWith lam as t -> do - (ListN as1 t1) <- evaluate c as - (ListN as2 _ ) <- evaluate c (ListE (map (evalLam lam) as1) (ListT (typeArrowResult (typeExp lam)))) - return $ ListN (map ((flip ListN) t1 . (map fst)) $ groupWith snd $ zip as1 as2) t - - AppE2 SortWith lam as t -> do - (ListN as1 _) <- evaluate c as - (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (ListT (typeArrowResult (typeExp lam)))) - return $ ListN (map fst $ sortWith snd $ zip as1 as2) t - - AppE2 Max e1 e2 IntegerT -> do - (IntegerN v1 _) <- evaluate c e1 - (IntegerN v2 _) <- evaluate c e2 - return $ IntegerN (max v1 v2) IntegerT - - AppE2 Max e1 e2 DoubleT -> do - (DoubleN v1 _) <- evaluate c e1 - (DoubleN v2 _) <- evaluate c e2 - return $ DoubleN (max v1 v2) DoubleT - - AppE2 Min e1 e2 IntegerT -> do - (IntegerN v1 _) <- evaluate c e1 - (IntegerN v2 _) <- evaluate c e2 - return $ IntegerN (min v1 v2) IntegerT - - AppE2 Min e1 e2 DoubleT -> do - (DoubleN v1 _) <- evaluate c e1 - (DoubleN v2 _) <- evaluate c e2 - return $ DoubleN (min v1 v2) DoubleT - - AppE1 The as _ -> do - (ListN as1 _) <- evaluate c as - return $ the as1 - - AppE1 Last as _ -> do - (ListN as1 _) <- evaluate c as - return $ last as1 - - AppE1 Init as t -> do - (ListN as1 _) <- evaluate c as - return $ ListN (init as1) t - - AppE1 Null as _ -> do - (ListN as1 _) <- evaluate c as - return $ BoolN (null as1) BoolT - - AppE1 Length as _ -> do - (ListN as1 _) <- evaluate c as - return $ IntegerN (fromIntegral $ length as1) IntegerT - - AppE2 Index as i _ -> do - (IntegerN i1 _) <- evaluate c i - (ListN as1 _) <- evaluate c as - return $ as1 !! (fromIntegral i1) - - AppE1 Reverse as t -> do - (ListN as1 _) <- evaluate c as - return $ ListN (reverse as1) t - - AppE1 And as _ -> do - (ListN as1 _) <- evaluate c as - return $ BoolN (and $ map (\(BoolN b BoolT) -> b) as1) BoolT - - AppE1 Or as _ -> do - (ListN as1 _) <- evaluate c as - return $ BoolN (or $ map (\(BoolN b BoolT) -> b) as1) BoolT - - AppE2 Any lam as _ -> do - (ListN as1 _) <- evaluate c as - (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (typeArrowResult (typeExp lam))) - return $ BoolN (any id $ map (\(BoolN b BoolT) -> b) as2) BoolT - - AppE2 All lam as _ -> do - (ListN as1 _) <- evaluate c as - (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (typeArrowResult (typeExp lam))) - return $ BoolN (all id $ map (\(BoolN b BoolT) -> b) as2) BoolT - - AppE1 Sum as IntegerT -> do - (ListN as1 _) <- evaluate c as - return $ IntegerN (sum $ map (\(IntegerN i IntegerT) -> i) as1) IntegerT - - AppE1 Sum as DoubleT -> do - (ListN as1 _) <- evaluate c as - return $ DoubleN (sum $ map (\(DoubleN d DoubleT) -> d) as1) DoubleT - - AppE1 Sum _ _ -> $impossible - - AppE1 Concat as t -> do - (ListN as1 _) <- evaluate c as - return $ ListN (concat $ map (\(ListN as2 _) -> as2) as1) t - - AppE1 Maximum as _ -> do - (ListN as1 _) <- evaluate c as - return $ maximum as1 - - AppE1 Minimum as _ -> do - (ListN as1 _) <- evaluate c as - return $ minimum as1 - - AppE2 SplitAt i as t -> do - (IntegerN i1 _) <- evaluate c i - (ListN as1 t1) <- evaluate c as - let r = splitAt (fromIntegral i1) as1 - return $ TupleN (ListN (fst r) t1) (ListN (snd r) t1) t - - AppE2 TakeWhile lam as t -> do - (ListN as1 _) <- evaluate c as - (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (typeArrowResult (typeExp lam))) - return $ ListN (map fst $ takeWhile (\(_,BoolN b BoolT) -> b) $ zip as1 as2) t - - AppE2 DropWhile lam as t -> do - (ListN as1 _) <- evaluate c as - (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (typeArrowResult (typeExp lam))) - return $ ListN (map fst $ dropWhile (\(_,BoolN b BoolT) -> b) $ zip as1 as2) t - - AppE2 Span lam as t -> do - (ListN as1 t1) <- evaluate c as - (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (typeArrowResult (typeExp lam))) - return $ (\(a,b) -> TupleN a b t) - $ (\(a,b) -> (ListN (map fst a) t1, ListN (map fst b) t1)) - $ span (\(_,BoolN b BoolT) -> b) - $ zip as1 as2 - - AppE2 Break lam as t -> do - (ListN as1 t1) <- evaluate c as - (ListN as2 _) <- evaluate c (ListE (map (evalLam lam) as1) (typeArrowResult (typeExp lam))) - return $ (\(a,b) -> TupleN a b t) - $ (\(a,b) -> (ListN (map fst a) t1, ListN (map fst b) t1)) - $ break (\(_,BoolN b BoolT) -> b) - $ zip as1 as2 - - AppE2 Zip as bs t -> do - (ListN as1 (ListT t1)) <- evaluate c as - (ListN bs1 (ListT t2)) <- evaluate c bs - return $ ListN (zipWith (\a b -> TupleN a b (TupleT t1 t2)) as1 bs1) t - - AppE1 Unzip as t -> do - (ListN as1 (ListT (TupleT t1 t2))) <- evaluate c as - return $ TupleN (ListN (map (\(TupleN a _ _) -> a) as1) (ListT t1)) - (ListN (map (\(TupleN _ b _) -> b) as1) (ListT t2)) - t - - AppE3 ZipWith lam as bs t -> do - (ListN as1 _) <- evaluate c as - (ListN bs1 _) <- evaluate c bs - evaluate c $ ListE (zipWith (\a b -> let lam1 = ((evalLam lam) a) in (evalLam lam1) b) as1 bs1) t - - AppE1 Nub as t -> do - (ListN as1 _) <- evaluate c as - return $ ListN (nub as1) t - - AppE1 Fst a _ -> do - (TupleN a1 _ _) <- evaluate c a - return a1 - - AppE1 Snd a _ -> do - (TupleN _ a1 _) <- evaluate c a - return a1 - - AppE2 Add e1 e2 IntegerT -> do - (IntegerN i1 _) <- evaluate c e1 - (IntegerN i2 _) <- evaluate c e2 - return $ IntegerN (i1 + i2) IntegerT - AppE2 Add e1 e2 DoubleT -> do - (DoubleN d1 _) <- evaluate c e1 - (DoubleN d2 _) <- evaluate c e2 - return $ DoubleN (d1 + d2) DoubleT - AppE2 Add _ _ _ -> $impossible - - AppE2 Sub e1 e2 IntegerT -> do - (IntegerN i1 _) <- evaluate c e1 - (IntegerN i2 _) <- evaluate c e2 - return $ IntegerN (i1 - i2) IntegerT - AppE2 Sub e1 e2 DoubleT -> do - (DoubleN d1 _) <- evaluate c e1 - (DoubleN d2 _) <- evaluate c e2 - return $ DoubleN (d1 - d2) DoubleT - AppE2 Sub _ _ _ -> $impossible - - AppE2 Mul e1 e2 IntegerT -> do - (IntegerN i1 _) <- evaluate c e1 - (IntegerN i2 _) <- evaluate c e2 - return $ IntegerN (i1 * i2) IntegerT - AppE2 Mul e1 e2 DoubleT -> do - (DoubleN d1 _) <- evaluate c e1 - (DoubleN d2 _) <- evaluate c e2 - return $ DoubleN (d1 * d2) DoubleT - AppE2 Mul _ _ _ -> $impossible - - AppE2 Div e1 e2 DoubleT -> do - (DoubleN d1 _) <- evaluate c e1 - (DoubleN d2 _) <- evaluate c e2 - return $ DoubleN (d1 / d2) DoubleT - AppE2 Div _ _ _ -> $impossible - - AppE1 IntegerToDouble e1 DoubleT -> do - (IntegerN i1 _) <- evaluate c e1 - return $ DoubleN (fromInteger i1) DoubleT - - AppE1 IntegerToDouble _ _ -> $impossible - - AppE2 Equ e1 e2 _ -> do - e3 <- evaluate c e1 - e4 <- evaluate c e2 - return $ BoolN (e3 == e4) BoolT - - AppE2 Lt e1 e2 _ -> do - e3 <- evaluate c e1 - e4 <- evaluate c e2 - return $ BoolN (e3 < e4) BoolT - - AppE2 Lte e1 e2 _ -> do - e3 <- evaluate c e1 - e4 <- evaluate c e2 - return $ BoolN (e3 <= e4) BoolT - - AppE2 Gte e1 e2 _ -> do - e3 <- evaluate c e1 - e4 <- evaluate c e2 - return $ BoolN (e3 >= e4) BoolT - - AppE2 Gt e1 e2 _ -> do - e3 <- evaluate c e1 - e4 <- evaluate c e2 - return $ BoolN (e3 > e4) BoolT + AppE Cons (PairE a as) -> do + a1 <- evaluate c a + (ListE as1) <- evaluate c as + return $ ListE (a1 : as1) + AppE Head as -> do + (ListE as1) <- evaluate c as + return $ head as1 + AppE Tail as -> do + (ListE as1) <- evaluate c as + return $ ListE (tail as1) + AppE Take (PairE i as) -> do + (IntegerE i1) <- evaluate c i + (ListE as1) <- evaluate c as + return $ ListE (take (fromIntegral i1) as1) + AppE Drop (PairE i as) -> do + (IntegerE i1) <- evaluate c i + (ListE as1) <- evaluate c as + return $ ListE (drop (fromIntegral i1) as1) + AppE Map (PairE (LamE f) as) -> do + (ListE as1) <- evaluate c as + evaluate c $ ListE (map f as1) + AppE Filter (PairE (LamE f) as) -> do + (ListE as1) <- evaluate c as + (ListE as2) <- evaluate c (ListE (map f as1)) + return $ ListE (map fst (filter (\(_,BoolE b) -> b) (zip as1 as2))) + AppE GroupWith (PairE (LamE f) as) -> do + (ListE as1) <- evaluate c as + (ListE as2) <- evaluate c (ListE (map f as1)) + return $ ListE + $ map (ListE . map fst) + $ groupBy (\(_,a1) (_,a2) -> equExp a1 a2) + $ sortBy (\(_,a1) (_,a2) -> compareExp a1 a2) + $ zip as1 as2 + AppE SortWith (PairE (LamE f) as) -> do + (ListE as1) <- evaluate c as + (ListE as2) <- evaluate c $ ListE (map f as1) + return $ ListE + $ map fst + $ sortBy (\(_,a1) (_,a2) -> compareExp a1 a2) + $ zip as1 as2 + (AppE Max (PairE e1 e2)) -> + case reify (undefined :: a) of + IntegerT -> do + (IntegerE v1) <- evaluate c e1 + (IntegerE v2) <- evaluate c e2 + return $ IntegerE (max v1 v2) + DoubleT -> do + (DoubleE v1) <- evaluate c e1 + (DoubleE v2) <- evaluate c e2 + return $ DoubleE (max v1 v2) + _ -> $impossible + (AppE Min (PairE e1 e2)) -> + case reify (undefined :: a) of + IntegerT -> do + (IntegerE v1) <- evaluate c e1 + (IntegerE v2) <- evaluate c e2 + return $ IntegerE (min v1 v2) + DoubleT -> do + (DoubleE v1) <- evaluate c e1 + (DoubleE v2) <- evaluate c e2 + return $ DoubleE (min v1 v2) + _ -> $impossible + AppE The as -> do + (ListE as1) <- evaluate c as + case as1 of + [] -> error "Database.DSH.Interpreter.the: empty list" + (x : xs) -> return $ if all (equExp x) xs + then x + else error "Database.DSH.Interpreter.the: non-identical elements" + AppE Last as -> do + (ListE as1) <- evaluate c as + return $ last as1 + AppE Init as -> do + (ListE as1) <- evaluate c as + return $ ListE (init as1) + AppE Null as -> do + (ListE as1) <- evaluate c as + return $ BoolE (null as1) + AppE Length as -> do + (ListE as1) <- evaluate c as + return $ IntegerE (fromIntegral $ length as1) + AppE Index (PairE as i) -> do + (IntegerE i1) <- evaluate c i + (ListE as1) <- evaluate c as + return $ as1 !! fromIntegral i1 + AppE Reverse as -> do + (ListE as1) <- evaluate c as + return $ ListE (reverse as1) + AppE And as -> do + (ListE as1) <- evaluate c as + return $ BoolE (all (\(BoolE b) -> b) as1) + AppE Or as -> do + (ListE as1) <- evaluate c as + return $ BoolE (any (\(BoolE b) -> b) as1) + (AppE Sum as) -> do + let ty = reify (undefined :: a) + (ListE as1) <- evaluate c as + case ty of + IntegerT -> return $ IntegerE (sum $ map (\(IntegerE i) -> i) as1) + DoubleT -> return $ DoubleE (sum $ map (\(DoubleE d) -> d) as1) + _ -> $impossible + AppE Concat as -> do + (ListE as1) <- evaluate c as + return $ ListE (concatMap (\(ListE as2) -> as2) as1) + AppE Maximum as -> do + (ListE as1) <- evaluate c as + return $ maximumBy compareExp as1 + AppE Minimum as -> do + (ListE as1) <- evaluate c as + return $ minimumBy compareExp as1 + AppE SplitAt (PairE i as) -> do + (IntegerE i1) <- evaluate c i + (ListE as1) <- evaluate c as + let r = splitAt (fromIntegral i1) as1 + return $ PairE (ListE (fst r)) (ListE (snd r)) + AppE TakeWhile (PairE (LamE f) as) -> do + (ListE as1) <- evaluate c as + (ListE as2) <- evaluate c (ListE (map f as1)) + return $ ListE (map fst $ takeWhile (\(_,BoolE b) -> b) $ zip as1 as2) + AppE DropWhile (PairE (LamE f) as) -> do + (ListE as1) <- evaluate c as + (ListE as2) <- evaluate c (ListE (map f as1)) + return $ ListE (map fst $ dropWhile (\(_,BoolE b) -> b) $ zip as1 as2) + AppE Zip (PairE as bs) -> do + (ListE as1) <- evaluate c as + (ListE bs1) <- evaluate c bs + return $ ListE (zipWith PairE as1 bs1) + AppE Unzip as -> do + (ListE as1) <- evaluate c as + return $ PairE (ListE (map (\(PairE a _) -> a) as1)) (ListE (map (\(PairE _ b) -> b) as1)) + AppE Nub as -> do + (ListE as1) <- evaluate c as + return $ ListE (nubBy equExp as1) + AppE Fst a -> do + (PairE a1 _) <- evaluate c a + return a1 + AppE Snd a -> do + (PairE _ a1) <- evaluate c a + return a1 + (AppE Add (PairE e1 e2)) -> do + let ty = reify (undefined :: a) + case ty of + IntegerT -> do + (IntegerE i1) <- evaluate c e1 + (IntegerE i2) <- evaluate c e2 + return $ IntegerE (i1 + i2) + DoubleT -> do + (DoubleE d1) <- evaluate c e1 + (DoubleE d2) <- evaluate c e2 + return $ DoubleE (d1 + d2) + _ -> $impossible + (AppE Sub (PairE e1 e2)) -> do + let ty = reify (undefined :: a) + case ty of + IntegerT -> do + (IntegerE i1) <- evaluate c e1 + (IntegerE i2) <- evaluate c e2 + return $ IntegerE (i1 - i2) + DoubleT -> do + (DoubleE d1) <- evaluate c e1 + (DoubleE d2) <- evaluate c e2 + return $ DoubleE (d1 - d2) + _ -> $impossible + (AppE Mul (PairE e1 e2)) -> do + let ty = reify (undefined :: a) + case ty of + IntegerT -> do + (IntegerE i1) <- evaluate c e1 + (IntegerE i2) <- evaluate c e2 + return $ IntegerE (i1 * i2) + DoubleT -> do + (DoubleE d1) <- evaluate c e1 + (DoubleE d2) <- evaluate c e2 + return $ DoubleE (d1 * d2) + _ -> $impossible + (AppE Div (PairE e1 e2)) -> do + let ty = reify (undefined :: a) + case ty of + DoubleT -> do + (DoubleE d1) <- evaluate c e1 + (DoubleE d2) <- evaluate c e2 + return $ DoubleE (d1 / d2) + _ -> $impossible + AppE IntegerToDouble e1 -> do + (IntegerE i1) <- evaluate c e1 + return $ DoubleE (fromInteger i1) + AppE Equ (PairE e1 e2) -> do + e3 <- evaluate c e1 + e4 <- evaluate c e2 + return $ BoolE $ equExp e3 e4 + AppE Lt (PairE e1 e2) -> do + e3 <- evaluate c e1 + e4 <- evaluate c e2 + return $ BoolE $ ltExp e3 e4 + AppE Lte (PairE e1 e2) -> do + e3 <- evaluate c e1 + e4 <- evaluate c e2 + return $ BoolE $ lteExp e3 e4 + AppE Gte (PairE e1 e2) -> do + e3 <- evaluate c e1 + e4 <- evaluate c e2 + return $ BoolE $ gteExp e3 e4 + AppE Gt (PairE e1 e2) -> do + e3 <- evaluate c e1 + e4 <- evaluate c e2 + return $ BoolE $ gtExp e3 e4 + AppE Not e1 -> do + (BoolE b1) <- evaluate c e1 + return $ BoolE (not b1) + AppE Conj (PairE e1 e2) -> do + (BoolE b1) <- evaluate c e1 + (BoolE b2) <- evaluate c e2 + return $ BoolE (b1 && b2) + AppE Disj (PairE e1 e2) -> do + (BoolE b1) <- evaluate c e1 + (BoolE b2) <- evaluate c e2 + return $ BoolE (b1 || b2) + (TableE (TableDB tName _)) -> + let ty = reify (undefined :: a) + in case ty of + ListT tType -> do + tDesc <- describeTable c (escape tName) + let columnNames = intercalate " , " $ map (\s -> "\"" ++ s ++ "\"") $ sort $ map fst tDesc + let query = "SELECT " ++ columnNames ++ " FROM " ++ "\"" ++ escape tName ++ "\"" + -- print query + fmap (sqlToExpWithType (escape tName) tType) (quickQuery c query []) + _ -> $impossible + (TableE (TableCSV filename)) -> csvImport filename (reify (undefined :: a)) + _ -> $impossible - AppE1 Not e1 _ -> do - (BoolN b1 _) <- evaluate c e1 - return $ BoolN (not b1) BoolT +compareExp :: Exp a -> Exp a -> Ordering +compareExp UnitE UnitE = EQ +compareExp (BoolE v1) (BoolE v2) = compare v1 v2 +compareExp (CharE v1) (CharE v2) = compare v1 v2 +compareExp (IntegerE v1) (IntegerE v2) = compare v1 v2 +compareExp (DoubleE v1) (DoubleE v2) = compare v1 v2 +compareExp (TextE v1) (TextE v2) = compare v1 v2 +compareExp (PairE a1 b1) (PairE a2 b2) = case compareExp a1 a2 of + EQ -> compareExp b1 b2 + LT -> LT + GT -> GT +compareExp (ListE []) (ListE []) = EQ +compareExp (ListE (_ : _)) (ListE []) = GT +compareExp (ListE []) (ListE (_ : _)) = LT +compareExp (ListE (a : as)) (ListE (b : bs)) = case compareExp a b of + EQ -> compareExp (ListE as) (ListE bs) + LT -> LT + GT -> GT +compareExp _ _ = $impossible - AppE2 Conj e1 e2 _ -> do - (BoolN b1 _) <- evaluate c e1 - (BoolN b2 _) <- evaluate c e2 - return $ BoolN (b1 && b2) BoolT +equExp :: Exp a -> Exp a -> Bool +equExp a b = case compareExp a b of + EQ -> True + _ -> False - AppE2 Disj e1 e2 _ -> do - (BoolN b1 _) <- evaluate c e1 - (BoolN b2 _) <- evaluate c e2 - return $ BoolN (b1 || b2) BoolT +ltExp :: Exp a -> Exp a -> Bool +ltExp a b = case compareExp a b of + LT -> True + _ -> False - TableE (TableDB (escape -> tName) _) (ListT tType) -> do - tDesc <- describeTable c tName - let columnNames = concat $ intersperse " , " $ map (\s -> "\"" ++ s ++ "\"") $ sort $ map fst tDesc - let query = "SELECT " ++ columnNames ++ " FROM " ++ "\"" ++ tName ++ "\"" - print query - fmap (sqlToNormWithType tName tType) (quickQuery c query []) - TableE (TableCSV filename) t -> csvImport filename t - TableE _ _ -> $impossible +lteExp :: Exp a -> Exp a -> Bool +lteExp a b = case compareExp a b of + GT -> False + _ -> True +gteExp :: Exp a -> Exp a -> Bool +gteExp a b = case compareExp a b of + LT -> False + _ -> True -snoc :: [a] -> a -> [a] -snoc [] a = [a] -snoc (b : bs) a = b : snoc bs a +gtExp :: Exp a -> Exp a -> Bool +gtExp a b = case compareExp a b of + GT -> True + _ -> False escape :: String -> String escape [] = [] escape (c : cs) | c == '"' = '\\' : '"' : escape cs escape (c : cs) = c : escape cs -evalLam :: Exp -> (Norm -> Exp) -evalLam (LamE f _) n = f (convert n) -evalLam _ _ = $impossible - - -- | Read SQL values into 'Norm' values -sqlToNormWithType :: String -- ^ Table name, used to generate more - -- informative error messages - -> Type - -> [[SqlValue]] - -> Norm -sqlToNormWithType tName ty = (flip ListN) (ListT ty) . map (sqlValueToNorm ty) - +sqlToExpWithType :: (Reify a) + => String -- ^ Table name, used to generate more informative error messages + -> Type a + -> [[SqlValue]] + -> Exp [a] +sqlToExpWithType tName ty = ListE . map (sqlValueToNorm ty) where - sqlValueToNorm :: Type -> [SqlValue] -> Norm - + sqlValueToNorm :: Type a -> [SqlValue] -> Exp a + sqlValueToNorm (PairT t1 t2) s = let v1 = sqlValueToNorm t1 $ take (sizeOfType t1) s + v2 = sqlValueToNorm t2 $ drop (sizeOfType t1) s + in PairE v1 v2 -- On a single value, just compare the 'Type' and convert the 'SqlValue' to -- a Norm value on match sqlValueToNorm t [s] = if t `typeMatch` s - then convert s + then convert s t else typeError t [s] - - -- On more than one value we need a 'TupleT' type of the exact same length - sqlValueToNorm t s | length (unfoldType t) == length s = - let f t' s' = if t' `typeMatch` s' - then convert s' - else typeError t s - in foldr1 (\a b -> TupleN a b (TupleT (typeNorm a) (typeNorm b))) - (zipWith f (unfoldType t) s) - -- Everything else will raise an error sqlValueToNorm t s = typeError t s - typeError :: Type -> [SqlValue] -> a + typeError :: Type a -> [SqlValue] -> b typeError t s = error $ "ferry: Type mismatch on table \"" ++ tName ++ "\":" ++ "\n\tExpected table type: " ++ show t ++ "\n\tTable entry: " ++ show s +convert :: SqlValue -> Type a -> Exp a +convert SqlNull UnitT = UnitE +convert (SqlInteger i) IntegerT = IntegerE i +convert (SqlInt32 i) IntegerT = IntegerE $ fromIntegral i +convert (SqlInt64 i) IntegerT = IntegerE $ fromIntegral i +convert (SqlWord32 i) IntegerT = IntegerE $ fromIntegral i +convert (SqlWord64 i) IntegerT = IntegerE $ fromIntegral i +convert (SqlDouble d) DoubleT = DoubleE d +convert (SqlRational d) DoubleT = DoubleE $ fromRational d +convert (SqlInteger d) DoubleT = DoubleE $ fromIntegral d +convert (SqlInt32 d) DoubleT = DoubleE $ fromIntegral d +convert (SqlInt64 d) DoubleT = DoubleE $ fromIntegral d +convert (SqlWord32 d) DoubleT = DoubleE $ fromIntegral d +convert (SqlWord64 d) DoubleT = DoubleE $ fromIntegral d +convert (SqlBool b) BoolT = BoolE b +convert (SqlInteger i) BoolT = BoolE (i /= 0) +convert (SqlInt32 i) BoolT = BoolE (i /= 0) +convert (SqlInt64 i) BoolT = BoolE (i /= 0) +convert (SqlWord32 i) BoolT = BoolE (i /= 0) +convert (SqlWord64 i) BoolT = BoolE (i /= 0) +convert (SqlChar c) CharT = CharE c +convert (SqlString (c:_)) CharT = CharE c +convert (SqlByteString c) CharT = CharE (head $ T.unpack $ T.decodeUtf8 c) +convert (SqlString t) TextT = TextE (T.pack t) +convert (SqlByteString s) TextT = TextE (T.decodeUtf8 s) +convert sql _ = error $ "Unsupported SqlValue: " ++ show sql +sizeOfType :: Type a -> Int +sizeOfType UnitT = 1 +sizeOfType IntegerT = 1 +sizeOfType DoubleT = 1 +sizeOfType BoolT = 1 +sizeOfType CharT = 1 +sizeOfType TextT = 1 +sizeOfType (PairT t1 t2) = sizeOfType t1 + sizeOfType t2 +sizeOfType _ = error "sizeOfType: Not a record type" + -- | Check if a 'SqlValue' matches a 'Type' -typeMatch :: Type -> SqlValue -> Bool +typeMatch :: Type a -> SqlValue -> Bool typeMatch t s = case (t,s) of (UnitT , SqlNull) -> True diff --git a/src/Database/DSH/JSON.hs b/src/Database/DSH/JSON.hs deleted file mode 100644 --- a/src/Database/DSH/JSON.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Database.DSH.JSON (jsonExport, jsonExportHandle, jsonExportStdout) where - -import Database.DSH.Data - -import Text.JSON - -import qualified Data.Text as Text - -import qualified System.IO as IO -import System.IO (Handle) - -jsonExport :: (QA a) => FilePath -> [a] -> IO () -jsonExport file as = IO.withFile file IO.WriteMode (\handle -> jsonExportHandle handle as) - -jsonExportStdout :: (QA a) => [a] -> IO () -jsonExportStdout = jsonExportHandle IO.stdout - -jsonExportHandle :: (QA a) => Handle -> [a] -> IO () -jsonExportHandle handle as = IO.hPutStr handle (encode $ go $ toNorm as) - where go :: Norm -> JSValue - go e = case e of - UnitN _ -> showJSON "()" - BoolN b _ -> showJSON b - CharN c _ -> showJSON c - IntegerN i _ -> showJSON i - DoubleN d _ -> showJSON d - TextN t _ -> showJSON (Text.unpack t) - TupleN e1 e2 _ -> JSArray $ map go (e1 : deTuple e2) - ListN es _ -> JSArray $ map go es - -deTuple :: Norm -> [Norm] -deTuple (TupleN e1 e2 _) = e1 : deTuple e2 -deTuple n = [n] diff --git a/src/Database/DSH/TH.hs b/src/Database/DSH/TH.hs --- a/src/Database/DSH/TH.hs +++ b/src/Database/DSH/TH.hs @@ -1,585 +1,255 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} - -module Database.DSH.TH - ( - deriveTupleQA - , generateDeriveTupleQARange - , deriveTupleTA - , generateDeriveTupleTARange - , deriveTupleView - , generateDeriveTupleViewRange - - , deriveQAForRecord - , deriveQAForRecord' - , deriveViewForRecord - , deriveViewForRecord' - , deriveTAForRecord - , deriveTAForRecord' - - , generateDatabaseRecordInstances - , generateTableRecordInstances - , generateRecordInstances - , generateTableDeclarations - ) where - - -import Database.DSH.Data -import Database.DSH.Impossible - -import Control.Applicative -import Control.Monad -import Data.Convertible -import Data.Char -import Data.List -import Database.HDBC -import Data.Text (Text) --- import Data.Time (UTCTime) -import GHC.Exts - -import Language.Haskell.TH hiding (Q, TupleT, tupleT, AppE, VarE, reify, Type, ListT) -import qualified Language.Haskell.TH as TH -import Language.Haskell.TH.Syntax (sequenceQ) - - --- Create a "a -> b -> ..." type -arrowChainT :: [TypeQ] -> TypeQ -arrowChainT [] = $impossible -arrowChainT as = foldr1 (\a b -> arrowT `appT` a `appT` b) as - --- Apply a list of 'TypeQ's to a type constructor -applyChainT :: TypeQ -> [TypeQ] -> TypeQ -applyChainT t ts = foldl' appT t ts - --- Apply a list of 'Exp's to a some 'Exp' -applyChainE :: ExpQ -> [ExpQ] -> ExpQ -applyChainE e es = foldl' appE e es - -applyChainTupleP :: [PatQ] -> PatQ -applyChainTupleP = foldr1 (\p1 p2 -> conP 'TupleN [p1,p2,wildP]) - -applyChainTupleE :: Name -> [ExpQ] -> ExpQ -applyChainTupleE n = foldr1 (\e1 e2 -> appE (appE (conE n) e1) e2) - - --------------------------------------------------------------------------------- --- * QA instances --- - --- Original Code --- instance (QA a,QA b) => QA (a,b) where --- reify _ = TupleT (reify (undefined :: a)) (reify (undefined :: b)) --- toNorm (a,b) = TupleN (toNorm a) (toNorm b) (reify (a,b)) --- fromNorm (TupleN a b (TupleT _ _)) = (fromNorm a,fromNorm b) --- fromNorm _ = $impossible - -deriveTupleQA :: Int -> TH.Q [Dec] -deriveTupleQA l - | l < 2 = $impossible - | otherwise = pure `fmap` instanceD qaCxts - qaType - qaDecs - - where - names@(a:b:rest) = [ mkName $ "a" ++ show i | i <- [1..l] ] - - qaCxts = return [ ClassP ''QA [VarT n] | n <- names ] - qaType = conT ''QA `appT` applyChainT (TH.tupleT l) (map varT names) - qaDecs = [ reifyDec - , fromNormDec - , toNormDec - ] - - -- The class functions: - - reifyDec = funD 'reify [reifyClause] - reifyClause = clause [ wildP ] - ( normalB $ applyChainTupleE 'TupleT [ [| reify (undefined :: $_n) |] | _n <- map varT names ] ) - [] - - fromNormDec = funD 'fromNorm [fromNormClause, clause [TH.wildP] (normalB [| $impossible |]) [] ] - fromNormClause = clause [applyChainTupleP (map varP names)] - (normalB $ TH.tupE [ [| fromNorm $(varE n) |] | n <- names ]) - [] - - toNormDec = funD 'toNorm [toNormClause] - toNormClause = clause [ toNormClausePattern ] (normalB $ fst $ toNormClauseBody $ [ varE n | n <- names ]) [] - - toNormClausePattern = tupP [ varP n | n <- names ] - - toNormClauseBody [a1,b1] = - let t1 = [| TupleT (reify $a1) (reify $b1) |] - e1 = [| TupleN (toNorm $a1) (toNorm $b1) ($t1) |] - in (e1,t1) - toNormClauseBody (a1 : as1) = - let (e1,t1) = toNormClauseBody as1 - t2 = [| TupleT (reify $a1) ($t1) |] - e2 = [| TupleN (toNorm $a1) ($e1) ($t2) |] - in (e2,t2) - toNormClauseBody _ = $impossible - - --- | Generate all 'QA' instances for tuples within range. -generateDeriveTupleQARange :: Int -> Int -> TH.Q [Dec] -generateDeriveTupleQARange from to = - concat `fmap` sequenceQ [ deriveTupleQA n | n <- reverse [from..to] ] - - --------------------------------------------------------------------------------- --- * TA instances --- - --- Original code: --- instance (BasicType a, BasicType b, QA a, QA b) => TA (a,b) where - -deriveTupleTA :: Int -> TH.Q [Dec] -deriveTupleTA l - | l < 2 = $impossible - | otherwise = pure `fmap` instanceD taCxts - taType - taDecs - - where - names = [ mkName $ "a" ++ show i | i <- [1..l] ] - - taCxts = return $ concat [ [ClassP ''QA [VarT n], ClassP ''BasicType [VarT n]] | n <- names ] - taType = conT ''TA `appT` applyChainT (TH.tupleT l) (map varT names) - taDecs = [] - --- | Generate all 'TA' instances for tuples within range. -generateDeriveTupleTARange :: Int -> Int -> TH.Q [Dec] -generateDeriveTupleTARange from to = - concat `fmap` sequenceQ [ deriveTupleTA n | n <- reverse [from..to] ] - - --------------------------------------------------------------------------------- --- * View pattern --- - --- Original code: --- instance (QA a,QA b) => View (Q (a,b)) (Q a, Q b) where --- view (Q a) = (Q (AppE (VarE "proj_2_1") a), Q (AppE (VarE "proj_2_1") a)) - -deriveTupleView :: Int -> TH.Q [Dec] -deriveTupleView l - | l < 2 = $impossible - | otherwise = pure `fmap` instanceD viewCxts - viewType - viewDecs - - where - names = [ mkName $ "a" ++ show i | i <- [1..l] ] - a = mkName "a" - - first p = [| AppE1 Fst $p (typeTupleFst (typeExp $p)) |] - second p = [| AppE1 Snd $p (typeTupleSnd (typeExp $p)) |] - - viewCxts = return [ ClassP ''QA [VarT n] | n <- names ] - viewType = conT ''View `appT` (conT ''Q `appT` applyChainT (TH.tupleT l) (map varT names)) - `appT` applyChainT (TH.tupleT l) [ conT ''Q `appT` varT n | n <- names ] - - viewDecs = [ viewDec, fromViewDec ] - - viewDec = funD 'view [viewClause] - viewClause = clause [ conP 'Q [varP a] ] - ( normalB $ TH.tupE [ if pos == l then [| Q $(f (varE a)) |] else [| Q $(first (f (varE a))) |] - | pos <- [1..l] - , let f = foldr (.) id (replicate (pos - 1) second) - ]) - [] - - fromViewDec = funD 'fromView [fromViewClause] - fromViewClause = clause [ fromViewClausePattern ] - ( normalB [| Q $(fst $ fromViewClauseBody (map varE names)) |] ) - [] - - fromViewClausePattern = tupP (map (\n -> conP 'Q [varP n]) names) - - fromViewClauseBody [a1,b1] = - let t1 = [| TupleT (typeExp $a1) (typeExp $b1) |] - e1 = [| TupleE ($a1) ($b1) ($t1) |] - in (e1,t1) - fromViewClauseBody (a1 : as1) = - let (e1,t1) = fromViewClauseBody as1 - t2 = [| TupleT (typeExp $a1) ($t1) |] - e2 = [| TupleE ($a1) ($e1) ($t2) |] - in (e2,t2) - fromViewClauseBody _ = $impossible - - --- | Generate all 'View' instances for tuples within range. -generateDeriveTupleViewRange :: Int -> Int -> TH.Q [Dec] -generateDeriveTupleViewRange from to = - concat `fmap` sequenceQ [ deriveTupleView n | n <- reverse [from..to] ] - - --------------------------------------------------------------------------------- --- * Deriving Instances for Records --- - --- | Derive the 'QA' instance for a record definition. -deriveQAForRecord :: TH.Q [Dec] -> TH.Q [Dec] -deriveQAForRecord q = do - records <- q - instances <- deriveQAForRecord' q - return (records ++ instances) - --- | Add 'QA' instance to a record without adding the actual data definition. --- Usefull in combination with 'deriveQAForRecord'' -deriveQAForRecord' :: TH.Q [Dec] -> TH.Q [Dec] -deriveQAForRecord' q = do - d <- q - mapM addInst d - where - addInst d@(DataD [] dName [] [RecC rName rVar@(_:_)] _) | dName == rName = do - - let rCxt = return [] - rType = conT ''QA `appT` conT dName - rDec = [ reifyDec - , toNormDec - , fromNormDec - ] - - reifyDec = funD 'reify [reifyClause] - reifyClause = clause [ wildP ] - ( normalB $ applyChainTupleE 'TupleT [ [| reify (undefined :: $(return _t)) |] | (_,_,_t) <- rVar] ) - [] - - names = [ mkName $ "a" ++ show i | i <- [1..length rVar] ] - - fromNormDec = funD 'fromNorm [fromNormClause, failClause] - fromNormClause = clause [ applyChainTupleP (map varP names) ] - ( normalB $ (conE dName) `applyChainE` [ [| fromNorm $(varE n) |] - | n <- names - ] - ) - [] - - -- Fail with a verbose message where this happened - failClause = clause [ wildP ] - ( do loc <- location - let pos = show (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc)) - normalB [| error $ "ferry: Impossible `fromNorm' at location " ++ pos |] - ) - [] - - toNormDec = funD 'toNorm [toNormClause] - toNormClause = clause [ conP dName (map varP names) ] - ( normalB $ fst $ toNormClauseBody $ [ varE n | n <- names ] ) - [] - - toNormClauseBody [a1,b1] = - let t1 = [| TupleT (reify $a1) (reify $b1) |] - e1 = [| TupleN (toNorm $a1) (toNorm $b1) ($t1) |] - in (e1,t1) - toNormClauseBody (a1 : as1) = - let (e1,t1) = toNormClauseBody as1 - t2 = [| TupleT (reify $a1) ($t1) |] - e2 = [| TupleN (toNorm $a1) ($e1) ($t2) |] - in (e2,t2) - toNormClauseBody _ = $impossible - - - instanceD rCxt - rType - rDec - - addInst _ = error "ferry: Failed to derive 'QA' - Invalid record definition" +module Database.DSH.TH (deriveQA, deriveTupleRangeQA, deriveElim) where --- | Derive the 'View' instance for a record definition. See --- 'deriveQAForRecord' for an example. -deriveViewForRecord :: TH.Q [Dec] -> TH.Q [Dec] -deriveViewForRecord q = do - recrods <- q - instances <- deriveViewForRecord' q - return (recrods ++ instances) +import qualified Database.DSH.Internals as DSH +import qualified Database.DSH.Impossible as DSH --- | Add 'View' instance to a record without adding the actual data definition. --- Usefull in combination with 'deriveQAForRecord'' -deriveViewForRecord' :: TH.Q [Dec] -> TH.Q [Dec] -deriveViewForRecord' q = do - d <- q - concat `fmap` mapM addView d - where - addView (DataD [] dName [] [RecC rName rVar@(_:_)] dNames) | dName == rName = do +import Language.Haskell.TH - -- The "View" record definition +----------------- +-- Deriving QA -- +----------------- - let vName = mkName $ nameBase dName ++ "V" - vRec = recC vName [ return (prefixV n, s, makeQ t) | (n,s,t) <- rVar ] +deriveQA :: Name -> Q [Dec] +deriveQA name = do + info <- reify name + case info of + TyConI (DataD _cxt name1 tyVarBndrs cons _names) -> deriveTyConQA name1 tyVarBndrs cons + TyConI (NewtypeD _cxt name1 tyVarBndrs con _names) -> deriveTyConQA name1 tyVarBndrs [con] + _ -> fail errMsgExoticType - prefixV :: Name -> Name - prefixV n = mkName $ nameBase n ++ "V" +deriveTyConQA :: Name -> [TyVarBndr] -> [Con] -> Q [Dec] +deriveTyConQA name tyVarBndrs cons = do + let context = map (\tv -> ClassP ''DSH.QA [VarT (tyVarBndrToName tv)]) tyVarBndrs + let typ = foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs) + let instanceHead = AppT (ConT ''DSH.QA) typ + let repDec = deriveRep typ cons + toExpDec <- deriveToExp cons + frExpDec <- deriveFrExp cons + return [InstanceD context instanceHead [repDec,toExpDec,frExpDec]] - makeQ :: TH.Type -> TH.Type - makeQ t = ConT ''Q `AppT` t +deriveTupleRangeQA :: Int -> Int -> Q [Dec] +deriveTupleRangeQA x y = fmap concat (mapM (deriveQA . tupleTypeName) [x .. y]) - vNames = [] --dNames +-- Derive the Rep type function - v <- dataD (return []) - vName - [] - [vRec] - vNames +deriveRep :: Type -> [Con] -> Dec +deriveRep typ cons = TySynInstD ''DSH.Rep [typ] (deriveRepCons cons) - -- The instance definition +deriveRepCons :: [Con] -> Type +deriveRepCons [] = error errMsgExoticType +deriveRepCons [c] = deriveRepCon c +deriveRepCons cs = foldr1 (AppT . AppT (ConT ''(,))) + (map (AppT (ConT ''[]) . deriveRepCon) cs) - let rCxt = return [] - rType = conT ''View `appT` (conT ''Q `appT` conT dName) - `appT` (conT vName) - rDec = [ viewDec - , fromViewDec - ] +deriveRepCon :: Con -> Type +deriveRepCon con = case conToTypes con of + [] -> ConT ''() + ts -> foldr1 (AppT . AppT (ConT ''(,))) + (map (AppT (ConT ''DSH.Rep)) ts) - a = mkName "a" +-- Derive the toExp function of the QA class - first p = [| AppE1 Fst $p (typeTupleFst (typeExp $p)) |] - second p = [| AppE1 Snd $p (typeTupleSnd (typeExp $p)) |] +deriveToExp :: [Con] -> Q Dec +deriveToExp [] = fail errMsgExoticType +deriveToExp cons = do + clauses <- sequence (zipWith3 deriveToExpClause (repeat (length cons)) [0 .. ] cons) + return (FunD 'DSH.toExp clauses) - viewDec = funD 'view [viewClause] - viewClause = clause [ conP 'Q [varP a] ] - ( normalB $ applyChainE (conE vName) - $ map (appE (conE 'Q)) - $ [ if pos == length rVar then (f (varE a)) else (first (f (varE a))) - | pos <- [1 .. length rVar] - , let f = foldr (.) id (replicate (pos - 1) second) - ] ) - [] +deriveToExpClause :: Int -- Total number of constructors + -> Int -- Index of the constructor + -> Con + -> Q Clause +deriveToExpClause 0 _ _ = fail errMsgExoticType +deriveToExpClause 1 _ con = do + (pat1,names1) <- conToPattern con + let exp1 = deriveToExpMainExp names1 + let body1 = NormalB exp1 + return (Clause [pat1] body1 []) +deriveToExpClause n i con = do + (pat1,names1) <- conToPattern con + let exp1 = deriveToExpMainExp names1 + expList1 <- [| DSH.ListE [ $(return exp1) ] |] + expEmptyList <- [| DSH.ListE [] |] + let lists = replicate i expEmptyList ++ [expList1] ++ replicate (n - i - 1) expEmptyList + let exp2 = foldr1 (AppE . AppE (ConE 'DSH.PairE)) lists + let body1 = NormalB exp2 + return (Clause [pat1] body1 []) - -- names for variables used in the `fromView' function - qs = [ mkName $ "q" ++ show i | i <- [1.. length rVar] ] +deriveToExpMainExp :: [Name] -> Exp +deriveToExpMainExp [] = ConE 'DSH.UnitE +deriveToExpMainExp [name] = AppE (VarE 'DSH.toExp) (VarE name) +deriveToExpMainExp names = foldr1 (AppE . AppE (ConE 'DSH.PairE)) + (map (AppE (VarE 'DSH.toExp) . VarE) names) +-- Derive to frExp function of the QA class - fromViewDec = funD 'fromView [fromViewClause] --, failClause] - fromViewClause = clause [ conP vName [ conP 'Q [varP q1] | q1 <- qs ] ] - ( normalB [| Q $(fst $ fromViewClauseBody (map varE qs)) |] ) - [] +deriveFrExp :: [Con] -> Q Dec +deriveFrExp cons = do + clauses <- sequence (zipWith3 deriveFrExpClause (repeat (length cons)) [0 .. ] cons) + imp <- DSH.impossible + let lastClause = Clause [WildP] (NormalB imp) [] + return (FunD 'DSH.frExp (clauses ++ [lastClause])) - fromViewClauseBody [a1,b1] = - let t1 = [| TupleT (typeExp $a1) (typeExp $b1) |] - e1 = [| TupleE ($a1) ($b1) ($t1) |] - in (e1,t1) - fromViewClauseBody (a1 : as1) = - let (e1,t1) = fromViewClauseBody as1 - t2 = [| TupleT (typeExp $a1) ($t1) |] - e2 = [| TupleE ($a1) ($e1) ($t2) |] - in (e2,t2) - fromViewClauseBody _ = $impossible +deriveFrExpClause :: Int -- Total number of constructors + -> Int -- Index of the constructor + -> Con + -> Q Clause +deriveFrExpClause 1 _ con = do + (_,names1) <- conToPattern con + let pat1 = deriveFrExpMainPat names1 + let exp1 = foldl AppE (ConE (conToName con)) (map (AppE (VarE 'DSH.frExp) . VarE) names1) + let body1 = NormalB exp1 + return (Clause [pat1] body1 []) +deriveFrExpClause n i con = do + (_,names1) <- conToPattern con + let pat1 = deriveFrExpMainPat names1 + let patList1 = ConP 'DSH.ListE [ConP '(:) [pat1,WildP]] + let lists = replicate i WildP ++ [patList1] ++ replicate (n - i - 1) WildP + let pat2 = foldr1 (\p1 p2 -> ConP 'DSH.PairE [p1,p2]) lists + let exp1 = foldl AppE (ConE (conToName con)) (map (AppE (VarE 'DSH.frExp) . VarE) names1) + let body1 = NormalB exp1 + return (Clause [pat2] body1 []) +deriveFrExpMainPat :: [Name] -> Pat +deriveFrExpMainPat [] = ConP 'DSH.UnitE [] +deriveFrExpMainPat [name] = VarP name +deriveFrExpMainPat names = foldr1 (\p1 p2 -> ConP 'DSH.PairE [p1,p2]) (map VarP names) +------------------- +-- Deriving Elim -- +------------------- - -- Fail with a verbose message where this happened - failClause = clause [ wildP ] - ( do loc <- location - let pos = show (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc)) - normalB [| error $ "ferry: Impossible `fromView' at location " ++ pos |] - ) - [] +deriveElim :: Name -> Q [Dec] +deriveElim name = do + info <- reify name + case info of + TyConI (DataD _cxt name1 tyVarBndrs cons _names) -> deriveTyConElim name1 tyVarBndrs cons + TyConI (NewtypeD _cxt name1 tyVarBndrs con _names) -> deriveTyConElim name1 tyVarBndrs [con] + _ -> fail errMsgExoticType - i <- instanceD rCxt - rType - rDec +deriveTyConElim :: Name -> [TyVarBndr] -> [Con] -> Q [Dec] +deriveTyConElim name tyVarBndrs cons = do + resultTyName <- newName "r" + let resTy = VarT resultTyName + let ty = foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs) + let context = (ClassP ''DSH.QA [ty]) : + (ClassP ''DSH.QA [resTy]) : + map (\tv -> ClassP ''DSH.QA [VarT (tyVarBndrToName tv)]) tyVarBndrs + let instanceHead = AppT (AppT (ConT ''DSH.Elim) ty) resTy + let eliminatorDec = deriveEliminator ty resTy cons + elimDec <- deriveElimFun cons + return [InstanceD context instanceHead [eliminatorDec,elimDec]] - return [v,i] +-- Derive the Eliminator type function - addView _ = error "ferry: Failed to derive 'View' - Invalid record definition" +deriveEliminator :: Type -> Type -> [Con] -> Dec +deriveEliminator typ resTy cons = TySynInstD ''DSH.Eliminator [typ,resTy] (deriveEliminatorCons resTy cons) +deriveEliminatorCons :: Type -> [Con] -> Type +deriveEliminatorCons _ [] = error errMsgExoticType +deriveEliminatorCons resTy cs = + foldr (AppT . AppT ArrowT) + (AppT (ConT ''DSH.Q) resTy) + (map (deriveEliminatorCon resTy) cs) --- | Derive 'TA' instances -deriveTAForRecord :: TH.Q [Dec] -> TH.Q [Dec] -deriveTAForRecord q = do - records <- q - instances <- deriveTAForRecord' q - return (records ++ instances) +deriveEliminatorCon :: Type -> Con -> Type +deriveEliminatorCon resTy con = + foldr (AppT . AppT ArrowT) + (AppT (ConT ''DSH.Q) resTy) + (map (AppT (ConT ''DSH.Q)) (conToTypes con)) -deriveTAForRecord' :: TH.Q [Dec] -> TH.Q [Dec] -deriveTAForRecord' q = q >>= mapM addTA - where - addTA (DataD [] dName [] [RecC rName (_:_)] _) | dName == rName = +-- Derive the elim function of the Elim type class - let taCxt = return [] - taType = conT ''TA `appT` conT dName - taDec = [ ] +deriveElimFun :: [Con] -> Q Dec +deriveElimFun cons = do + clause1 <- deriveElimFunClause cons + return (FunD 'DSH.elim [clause1]) - in instanceD taCxt - taType - taDec +deriveElimFunClause :: [Con] -> Q Clause +deriveElimFunClause cons = do + en <- newName "e" + fns <- mapM (\ _ -> newName "f") cons + let fes = map VarE fns + let pats1 = (ConP 'DSH.Q [VarP en]) : map VarP fns - addTA _ = error "ferry: Failed to derive 'TA' - Invalid record definition" + fes2 <- sequence (zipWith deriveElimToLamExp fes (map (length . conToTypes) cons)) + let e = VarE en + let liste = AppE (ConE 'DSH.ListE) (ListE (deriveElimFunClauseExp e fes2)) + let concate = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Concat)) liste + let heade = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Head)) concate + let qe = AppE (ConE 'DSH.Q) heade + return (Clause pats1 (NormalB qe) []) --- | Create lifted record selectors -recordQSelectors :: TH.Q [Dec] -> TH.Q [Dec] -recordQSelectors q = do - recrods <- q - selectors <- recordQSelectors' q - return (recrods ++ selectors) +deriveElimToLamExp :: Exp -> Int -> Q Exp +deriveElimToLamExp f 0 = + return (AppE (VarE 'const) (AppE (VarE 'DSH.unQ) f)) +deriveElimToLamExp f 1 = do + xn <- newName "x" + let xe = VarE xn + let xp = VarP xn + let qe = AppE (ConE 'DSH.Q) xe + let fappe = AppE f qe + let unqe = AppE (VarE 'DSH.unQ) fappe + return (LamE [xp] unqe) +deriveElimToLamExp f n = do + xn <- newName "x" + let xe = VarE xn + let xp = VarP xn + let fste = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Fst)) xe + let snde = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Snd)) xe + let qe = AppE (ConE 'DSH.Q) fste + let fappe = AppE f qe + f' <- deriveElimToLamExp fappe (n - 1) + return (LamE [xp] (AppE f' snde)) -recordQSelectors' :: TH.Q [Dec] -> TH.Q [Dec] -recordQSelectors' q = q >>= fmap join . mapM addSel +deriveElimFunClauseExp :: Exp -> [Exp] -> [Exp] +deriveElimFunClauseExp _ [] = error errMsgExoticType +deriveElimFunClauseExp e [f] = [AppE (ConE 'DSH.ListE) (ListE [AppE f e])] +deriveElimFunClauseExp e fs = go e fs where - addSel :: Dec -> TH.Q [Dec] - addSel (DataD [] dName [] [RecC rName vst] _) | dName == rName && not (null vst) = - - let namesAndTypes = [ (n, t') - | (n, _, t) <- vst - , let t' = arrowChainT [ conT ''Q `appT` conT dName - , conT ''Q `appT` return t - ] - ] - - addFunD (n,t) = let qn = mkName $ nameBase n ++ "Q" - vn = mkName $ nameBase n ++ "V" - in sequenceQ [ sigD qn t - , funD qn [ clause [] - (normalB [| $(varE vn) . view |]) - [] - ] - ] - - in if null namesAndTypes - then error "woot?" - else concat `fmap` mapM addFunD namesAndTypes - - addSel _ = error "ferry: Failed to create record selectors - Invalid record definition" - - --------------------------------------------------------------------------------- --- * Exported enduser functions --- - --- | Generate table declarations for all tables in the database. This function --- should be used in conjunction with generateDatabaseRecordInstances. For --- example, this function generates the following code for the table 'users': --- --- > users :: Q [User] --- > users = table "users" --- -generateTableDeclarations :: (IConnection conn) - => (IO conn) -- ^ Database connection - -> TH.Q [Dec] -generateTableDeclarations conn = do - tables <- runIO $ do c <- conn - r <- getTables c - disconnect c - return r - declss <- mapM generateTableDeclaration tables - return (concat declss) - -generateTableDeclaration :: String -> TH.Q [Dec] -generateTableDeclaration s = return - [ TH.SigD (mkName s) (TH.AppT (TH.ConT ''Q) (TH.AppT TH.ListT (TH.ConT (mkName (dataTypeName s))))) - , TH.FunD (mkName s) [TH.Clause [] (TH.NormalB (TH.AppE (TH.VarE (mkName "table")) (TH.LitE (TH.StringL s)))) []] - ] - --- | Create corresponding Haskell record data types and generate QA and View --- instances for all tables in the database (except for system tables). --- --- Example usage: --- --- > $(generateDatabaseRecordInstances myConnection) --- --- Note that the database information is queried at compile time, not at run time! -generateDatabaseRecordInstances :: (IConnection conn) - => (IO conn) -- ^ Database connection - -> TH.Q [Dec] -generateDatabaseRecordInstances conn = do - tables <- runIO $ do c <- conn - r <- getTables c - disconnect c - return r - decss <- mapM (\t -> generateTableRecordInstances conn t (dataTypeName t) [''Show,''Eq]) tables - return (concat decss) - -dataTypeName :: String -> String -dataTypeName [] = [] -dataTypeName [c] = map toUpper (cleanUnderscores [c]) -dataTypeName (c : cs) = toUpper c : cleanUnderscores (init cs) - -cleanUnderscores :: String -> String -cleanUnderscores [] = [] -cleanUnderscores ['_'] = [] -cleanUnderscores ('_' : c : cs) = toUpper c : cleanUnderscores cs -cleanUnderscores (c : cs) = c : cleanUnderscores cs - --- | Lookup a database table, create corresponding Haskell record data types --- and generate QA and View instances --- --- Example usage: --- --- > $(generateTableRecordInstances myConnection "users" "User" [''Show,''Eq]) --- --- Note that the table information is queried at compile time, not at run time! -generateTableRecordInstances :: (IConnection conn) - => (IO conn) -- ^ Database connection - -> String -- ^ Table name - -> String -- ^ Data type name for each row of the table - -> [Name] -- ^ Default deriving instances - -> TH.Q [Dec] -generateTableRecordInstances conn t dname dnames = do - tdesc <- runIO $ do c <- conn - r <- describeTable c t - disconnect c - return r - generateRecordInstances (createDataType (sortWith fst tdesc)) + go :: Exp -> [Exp] -> [Exp] + go _ [] = error errMsgExoticType + go e1 [f1] = + let paire = AppE (AppE (ConE 'DSH.PairE) (AppE (ConE 'DSH.LamE) f1)) e1 + in [AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Map)) paire] + go e1 (f1 : fs1) = + let fste = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Fst)) e1 + snde = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Snd)) e1 + paire = AppE (AppE (ConE 'DSH.PairE) (AppE (ConE 'DSH.LamE) f1)) fste + mape = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Map)) paire + in mape : go snde fs1 - where - createDataType :: [(String, SqlColDesc)] -> TH.Q [Dec] - createDataType [] = error "ferry: Empty table description" - createDataType ds = pure `fmap` dataD dCxt - dName - [] - [dCon ds] - dNames +-- Helper Functions - dName = mkName dname - dNames = dnames +conToTypes :: Con -> [Type] +conToTypes (NormalC _name strictTypes) = map snd strictTypes +conToTypes (RecC _name varStrictTypes) = map (\(_,_,t) -> t) varStrictTypes +conToTypes (InfixC st1 _name st2) = [snd st1,snd st2] +conToTypes (ForallC _tyVarBndrs _cxt con) = conToTypes con - dCxt = return [] - dCon desc = recC dName (map toVarStrictType desc) +tyVarBndrToName :: TyVarBndr -> Name +tyVarBndrToName (PlainTV name) = name +tyVarBndrToName (KindedTV name _kind) = name - -- no support for nullable columns yet: - toVarStrictType (n,SqlColDesc { colType = ty, colNullable = _ }) = - let t' = case convert ty of - IntegerT -> ConT ''Integer - BoolT -> ConT ''Bool - CharT -> ConT ''Char - DoubleT -> ConT ''Double - TextT -> ConT ''Text - _ -> $impossible +conToPattern :: Con -> Q (Pat,[Name]) +conToPattern (NormalC name strictTypes) = do + ns <- mapM (\ _ -> newName "x") strictTypes + return (ConP name (map VarP ns),ns) +conToPattern (RecC name varStrictTypes) = do + ns <- mapM (\ _ -> newName "x") varStrictTypes + return (ConP name (map VarP ns),ns) +conToPattern (InfixC st1 name st2) = do + ns <- mapM (\ _ -> newName "x") [st1,st2] + return (ConP name (map VarP ns),ns) +conToPattern (ForallC _tyVarBndr _cxt con) = conToPattern con - in return (mkName n, NotStrict, t') +conToName :: Con -> Name +conToName (NormalC name _) = name +conToName (RecC name _) = name +conToName (InfixC _ name _) = name +conToName (ForallC _ _ con) = conToName con +-- Error messages --- | Derive QA and View instances for record definitions --- --- Example usage: --- --- > $(generateRecordInstances [d| --- > --- > data User = User --- > { userId :: Int --- > , userName :: String --- > } --- > --- > |]) --- --- This generates the following record type, which can be used in view patterns --- --- > data UserV = UserV --- > { userIdV :: Q Int --- > , userNameV :: Q String --- > } --- --- > instance View (Q User) UserV --- --- and the liftet record selectors: --- --- > userIdQ :: Q User -> Q Int --- > userNameQ :: Q User -> Q String -generateRecordInstances :: TH.Q [Dec] -> TH.Q [Dec] -generateRecordInstances q = do - d <- q - qa <- deriveQAForRecord' q - v <- deriveViewForRecord' q - ta <- deriveTAForRecord' q - rs <- recordQSelectors' q - return (d ++ qa ++ v ++ ta ++ rs) +errMsgExoticType :: String +errMsgExoticType = "Automatic derivation of DSH related type class instances only works for Haskell 98 types." diff --git a/src/Database/DSH/XHTML.hs b/src/Database/DSH/XHTML.hs deleted file mode 100644 --- a/src/Database/DSH/XHTML.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Database.DSH.XHTML (xhtmlExport, xhtmlExportHandle, xhtmlExportStdout) where - -import Database.DSH.Data hiding (table) - -import Text.XHtml.Strict - -import qualified Data.Text as Text - -import qualified System.IO as IO -import System.IO (Handle) - -xhtmlExport :: (QA a) => FilePath -> [a] -> IO () -xhtmlExport file as = IO.withFile file IO.WriteMode (\handle -> xhtmlExportHandle handle as) - -xhtmlExportStdout :: (QA a) => [a] -> IO () -xhtmlExportStdout = xhtmlExportHandle IO.stdout - -xhtmlExportHandle :: (QA a) => Handle -> [a] -> IO () -xhtmlExportHandle handle as = IO.hPutStr handle (showHtmlFragment $ go 0 0 $ toNorm as) - where go :: Integer -> Integer -> Norm -> Html - go tl rl e = case e of - UnitN _ -> (td $ stringToHtml $ "()") ! [tdAttr tl rl] - BoolN b _ -> (td $ stringToHtml $ show b) ! [tdAttr tl rl] - CharN c _ -> (td $ stringToHtml $ [c]) ! [tdAttr tl rl] - IntegerN i _ -> (td $ stringToHtml $ show i) ! [tdAttr tl rl] - DoubleN d _ -> (td $ stringToHtml $ show d) ! [tdAttr tl rl] - TextN t _ -> (td $ stringToHtml $ Text.unpack t) ! [tdAttr tl rl] - TupleN e1 e2 _ -> (concatHtml $ map (go tl rl) (e1 : deTuple e2)) - ListN es _ -> td $ (table $ concatHtml - $ map (\(l1,e1) -> tr (go (tl + 1) l1 e1)) - $ zip [0 ..] es - ) ! [tableAttr] - - tdAttr :: Integer -> Integer -> HtmlAttr - tdAttr tl rl = case (odd tl,odd rl) of - (False,False) -> strAttr "style" "text-align:center; min-width:20px; padding:5px; background-color:#EEE;" - (False,True) -> strAttr "style" "text-align:center; min-width:20px; padding:5px; background-color:#CCC;" - (True,False) -> strAttr "style" "text-align:center; min-width:20px; padding:5px; background-color:#DDD;" - (True,True) -> strAttr "style" "text-align:center; min-width:20px; padding:5px; background-color:#E9E9E9;" - - tableAttr :: HtmlAttr - tableAttr = strAttr "style" "border-spacing:5px;" - - -deTuple :: Norm -> [Norm] -deTuple (TupleN e1 e2 _) = e1 : deTuple e2 -deTuple n = [n] diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - module Main where import qualified Database.DSH as Q @@ -62,7 +60,7 @@ qc prop_maybe_integer putStrPad "Either Integer Integer: " qc prop_either_integer - + putStrLn "" putStrLn "Equality, Boolean Logic and Ordering" putStrLn "------------------------------------" @@ -102,7 +100,7 @@ qc prop_fst putStrPad "snd" qc prop_snd - + putStrLn "" putStrLn "Numerics:" putStrLn "-----------" @@ -130,7 +128,7 @@ qc prop_negate_integer putStrPad "negate_double" qc prop_negate_double - + putStrLn "" putStrLn "Maybe" putStrLn "-----" @@ -174,7 +172,7 @@ qc prop_rights putStrPad "partitionEithers" qc prop_partitionEithers - + putStrLn "" putStrLn "Lists" putStrLn "-----" @@ -271,8 +269,8 @@ let hs = f2 arg assert (db == hs) -makePropNotNull :: (Eq b, Q.QA a, Q.QA b, Show a, Show b) - => (Q.Q [a] -> Q.Q b) +makePropNotNull :: (Eq b, QA a, QA b, Show a, Show b) + => (Q [a] -> Q b) -> ([a] -> b) -> [a] -> Property @@ -284,14 +282,14 @@ -> a -> Property makePropDouble f1 f2 arg = monadicIO $ do - c <- run $ getConn + c <- run getConn db <- run $ fromQ c $ f1 (Q.toQ arg) run $ HDBC.disconnect c let hs = f2 arg let eps = 1.0E-8 :: Double; assert (abs (db - hs) < eps) -uncurryQ :: (Q.QA a, Q.QA b) => (Q.Q a -> Q.Q b -> Q.Q c) -> Q.Q (a,b) -> Q.Q c +uncurryQ :: (QA a, QA b) => (Q a -> Q b -> Q c) -> Q (a,b) -> Q c uncurryQ f = uncurry f . Q.view -- * Supported Types @@ -347,7 +345,7 @@ prop_neq = makeProp (uncurryQ (Q./=)) (uncurry (/=)) prop_cond :: Bool -> Property -prop_cond = makeProp (\b -> Q.cond b (0 :: Q Integer) 1) (\b -> if b then 0 else 1) +prop_cond = makeProp (\b -> Q.cond b 0 1) (\b -> if b then (0 :: Integer) else 1) prop_lt :: (Integer, Integer) -> Property prop_lt = makeProp (uncurryQ (Q.<)) (uncurry (<)) @@ -419,7 +417,7 @@ prop_isRight :: Either Integer Integer -> Property prop_isRight = makeProp Q.isRight (\e -> case e of {Left _ -> False; Right _ -> True;}) -prop_either :: (Either Integer Integer) -> Property +prop_either :: Either Integer Integer -> Property prop_either = makeProp (Q.either id id) (either id id) prop_lefts :: [Either Integer Integer] -> Property @@ -440,7 +438,7 @@ prop_snoc = makeProp (uncurryQ (Q.|>)) (\(a,b) -> a ++ [b]) prop_singleton :: Integer -> Property -prop_singleton = makeProp Q.singleton (\x -> [x]) +prop_singleton = makeProp Q.singleton (: []) prop_head :: [Integer] -> Property prop_head = makePropNotNull Q.head head @@ -479,7 +477,7 @@ prop_map = makeProp (Q.map id) (map id) prop_append :: ([Integer], [Integer]) -> Property -prop_append = makeProp (uncurryQ (Q.><)) (\(a,b) -> a ++ b) +prop_append = makeProp (uncurryQ (Q.++)) (uncurry (++)) prop_filter :: [Integer] -> Property prop_filter = makeProp (Q.filter (const $ Q.toQ True)) (filter $ const True) @@ -494,7 +492,7 @@ prop_null = makeProp Q.null null prop_length :: [Integer] -> Property -prop_length = makeProp Q.length (fromIntegral . length) +prop_length = makeProp Q.length ((fromIntegral :: Int -> Integer) . length) prop_reverse :: [Integer] -> Property prop_reverse = makeProp Q.reverse reverse @@ -521,7 +519,7 @@ prop_concat = makeProp Q.concat concat prop_concatMap :: [Integer] -> Property -prop_concatMap = makeProp (Q.concatMap Q.singleton) (concatMap (\a -> [a])) +prop_concatMap = makeProp (Q.concatMap Q.singleton) (concatMap (: [])) prop_maximum :: [Integer] -> Property prop_maximum = makePropNotNull Q.maximum maximum @@ -549,16 +547,16 @@ (uncurry $ break . (==) . fromIntegral) prop_elem :: (Integer, [Integer]) -> Property -prop_elem = makeProp (uncurryQ $ Q.elem) - (uncurry $ elem) +prop_elem = makeProp (uncurryQ Q.elem) + (uncurry elem) prop_notElem :: (Integer, [Integer]) -> Property -prop_notElem = makeProp (uncurryQ $ Q.notElem) - (uncurry $ notElem) +prop_notElem = makeProp (uncurryQ Q.notElem) + (uncurry notElem) prop_lookup :: (Integer, [(Integer,Integer)]) -> Property -prop_lookup = makeProp (uncurryQ $ Q.lookup) - (uncurry $ lookup) +prop_lookup = makeProp (uncurryQ Q.lookup) + (uncurry lookup) prop_zip :: ([Integer], [Integer]) -> Property prop_zip = makeProp (uncurryQ Q.zip) (uncurry zip) diff --git a/tests/Makefile b/tests/Makefile --- a/tests/Makefile +++ b/tests/Makefile @@ -1,5 +1,5 @@ all: cabal - ghc -Wall -O3 --make Main.hs -o Main + ghc -Wall -O3 -fno-warn-orphans --make Main.hs -o Main ./Main hpc: cabal @@ -10,7 +10,7 @@ hpc markup Main cabal: clean - cd ..; cabal clean; cabal install; cd tests; + cd ..; cabal install; cd tests; clean: rm -rf tmp .hpc *.html *.tix *.o *.hi Main