packages feed

DSH 0.6.6 → 0.7

raw patch · 9 files changed

+62/−551 lines, 9 filesdep −haskell-src-extsdep −syntax-trees

Dependencies removed: haskell-src-exts, syntax-trees

Files

DSH.cabal view
@@ -1,7 +1,14 @@ Name:                DSH-Version:             0.6.6+Version:             0.7 Synopsis:            Database Supported Haskell Description:+  Note that DSH-0.7 is the very first, experimental release that is intended+  to be used with monad comprehensions (a Haskell extension available in+  GHC-7.2). For a currently stable version that implements comprehensions+  using quasiquoting please download DSH-0.6. The experimental changes in this+  version only affect the comprehension notation, the behaviour of the+  supported combinators is not affected.+  .   This is a Haskell library for database-supported program execution. Using   this library a relational database management system (RDBMS) can be used as   a coprocessor for the Haskell programming language, especially for those@@ -42,9 +49,7 @@ Category:            Database Build-type:          Simple -Extra-source-files:  examples/Example1.hs-                     examples/Example1_data.sql-                     examples/Example2.hs+Extra-source-files:  examples/Example01.hs                      tests/Main.hs                      tests/Makefile @@ -61,8 +66,6 @@                      HDBC               >= 2.2,                      convertible        >= 1.0,                      template-haskell   >= 2.4,-                     haskell-src-exts   >= 1.11,-                     syntax-trees       >= 0.1.2,                      HaXml              >= 1.22,                      csv                >= 0.1,                      Pathfinder         >= 0.5.8,@@ -76,11 +79,9 @@                      Database.DSH.Interpreter                      Database.DSH.Compiler -  Other-modules:     Database.DSH.QQ-                     Database.DSH.TH+  Other-modules:     Database.DSH.TH                      Database.DSH.Data                      Database.DSH.Combinators                      Database.DSH.CSV                      Database.DSH.Impossible                      Database.DSH.Compile-                     Paths_DSH
+ examples/Example01.hs view
@@ -0,0 +1,29 @@+-- This example was taken from the paper called "Comprehensive Comprehensions"+-- by Phil Wadler and Simon Peyton Jones++{-# LANGUAGE MonadComprehensions, RebindableSyntax, ViewPatterns #-}++module Main where++import qualified Prelude as P +import Database.DSH+import Database.DSH.Compiler++import Database.HDBC.PostgreSQL++ints :: Q [Integer]+ints = toQ [1 .. 10]++query :: Q [(Integer,Integer)]+query = [ tuple (i1, i2)+        | i1 <- ints+        , i2 <- ints+        ]++getConn :: IO Connection+getConn = connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'"++main :: IO ()+main = +  getConn          P.>>= \conn ->+  fromQ conn query P.>>= P.print
− examples/Example1.hs 
@@ -1,73 +0,0 @@--- This module is part of the DSH-Compiler package and serves as an example on--- howto use DSH. It is accompanied by a file ExampleData.sql that contains--- SQL instructions to setup the database that is used by this example.---- Quasiquoting has to be enabled to support the list comprehension syntax-{-# LANGUAGE QuasiQuotes #-}--module Main where---- We hide everything in the prelude as DSH exposes a lot of same combinators.--- In general we recommend to import the module Database.DSH module qualified.--- The Database.DSH.Compiler module has to be imported seperately this module--- contains the machinery necessary to execute the query. This module is part--- of the DSH-Compiler package, the other module (Database.DSH) is part of--- DSH-Core. We provide the modules in separate packages so that different--- backend can be made and used for the DSH query facility.--import Prelude () -import Database.DSH-import Database.DSH.Compiler---- For our example we use postgresql, any database will do as long it can be--- approached through HDBC.-import Database.HDBC.PostgreSQL---- Setup the connection string. In order for this to work you must provide a--- username, password, host and database name.-getConn :: IO Connection-getConn = connectPostgreSQL "user = 'postgres' password = 'haskell98' host = 'localhost' dbname = 'ferry'"---- DSH uses Text instead of string for strings, as a string will be treated as a--- list of characters.-type Facility = Text-type Cat      = Text-type Feature  = Text-type Meaning  = Text---- Declare the database tables, note that you *MUST* declare all columns--- present in a table. And all columns must be in the same order as they are--- declared in the database. During compilation the types of the columns will--- be checked against the provided haskell types. When possible the types of--- columns will be inferred, if they cannot be fully inferred the user has to--- provide explicit types!--facilities :: Q [(Cat, Facility)]-facilities = table "facilities"-               -features :: Q [(Facility, Feature)]-features = table "features"-          -meanings :: Q [(Feature, Meaning)]-meanings = table "meanings"-            --- Helper function for the query.--- Despite the different braces for the comprehension the comprehension body--- works as normal-descrFacility :: Q Facility -> Q [Meaning]-descrFacility f =  [$qc| mean | (feat,mean) <- meanings, -                                (fac,feat1) <- features, -                                feat == feat1 && fac == f|]---- Main query, use the helper function-query :: Q [(Text , [Text])] -query = [$qc| tuple (the cat, nub $ concatMap descrFacility fac) -            | (cat, fac) <- facilities, then group by cat |]----- Execute the query-main :: IO ()-main = do-  conn   <- getConn           -- Get a connection-  result <- fromQ conn query  -- Execute the query using fromQ-  print result
− examples/Example1_data.sql 
@@ -1,78 +0,0 @@--- DROP TABLE "facilities" CASCADE;--- DROP TABLE "features"   CASCADE;--- DROP TABLE "meanings"   CASCADE ;--CREATE TABLE "facilities" (-    facility text NOT NULL,-    categorie text NOT NULL-);--CREATE TABLE "features" (-    facility text NOT NULL,-    feature text NOT NULL-);--CREATE TABLE "meanings" (-    feature text NOT NULL,-    meaning text NOT NULL-);--INSERT INTO "facilities" (facility, categorie) VALUES ('SQL', 'QLA');-INSERT INTO "facilities" (facility, categorie) VALUES ('ODBC', 'API');-INSERT INTO "facilities" (facility, categorie) VALUES ('LINQ', 'LIN');-INSERT INTO "facilities" (facility, categorie) VALUES ('Links', 'LIN');-INSERT INTO "facilities" (facility, categorie) VALUES ('Rails', 'ORM');-INSERT INTO "facilities" (facility, categorie) VALUES ('Ferry', 'LIB');-INSERT INTO "facilities" (facility, categorie) VALUES ('Kleisli', 'QLA');-INSERT INTO "facilities" (facility, categorie) VALUES ('ADO.NET', 'ORM');-INSERT INTO "facilities" (facility, categorie) VALUES ('HaskellDB', 'LIB');--INSERT INTO "features" (facility, feature) VALUES ('Kleisli', 'nest');-INSERT INTO "features" (facility, feature) VALUES ('Kleisli', 'comp');-INSERT INTO "features" (facility, feature) VALUES ('Kleisli', 'type');-INSERT INTO "features" (facility, feature) VALUES ('Links', 'comp');-INSERT INTO "features" (facility, feature) VALUES ('Links', 'type');-INSERT INTO "features" (facility, feature) VALUES ('Links', 'SQL');-INSERT INTO "features" (facility, feature) VALUES ('LINQ', 'nest');-INSERT INTO "features" (facility, feature) VALUES ('LINQ', 'comp');-INSERT INTO "features" (facility, feature) VALUES ('LINQ', 'type');-INSERT INTO "features" (facility, feature) VALUES ('HaskellDB', 'comp');-INSERT INTO "features" (facility, feature) VALUES ('HaskellDB', 'type');-INSERT INTO "features" (facility, feature) VALUES ('HaskellDB', 'SQL');-INSERT INTO "features" (facility, feature) VALUES ('SQL', 'aval');-INSERT INTO "features" (facility, feature) VALUES ('SQL', 'type');-INSERT INTO "features" (facility, feature) VALUES ('SQL', 'SQL');-INSERT INTO "features" (facility, feature) VALUES ('Rails', 'nest');-INSERT INTO "features" (facility, feature) VALUES ('Rails', 'maps');-INSERT INTO "features" (facility, feature) VALUES ('ADO.NET', 'maps');-INSERT INTO "features" (facility, feature) VALUES ('ADO.NET', 'comp');-INSERT INTO "features" (facility, feature) VALUES ('ADO.NET', 'type');-INSERT INTO "features" (facility, feature) VALUES ('Ferry', 'list');-INSERT INTO "features" (facility, feature) VALUES ('Ferry', 'nest');-INSERT INTO "features" (facility, feature) VALUES ('Ferry', 'comp');-INSERT INTO "features" (facility, feature) VALUES ('Ferry', 'aval');-INSERT INTO "features" (facility, feature) VALUES ('Ferry', 'type');-INSERT INTO "features" (facility, feature) VALUES ('Ferry', 'SQL');--INSERT INTO "meanings" (feature, meaning) VALUES ('maps', 'admits user-defined object mappings');-INSERT INTO "meanings" (feature, meaning) VALUES ('list', 'respects list order');-INSERT INTO "meanings" (feature, meaning) VALUES ('nest', 'supports data nesting');-INSERT INTO "meanings" (feature, meaning) VALUES ('comp', 'has compositional syntax and semantics');-INSERT INTO "meanings" (feature, meaning) VALUES ('aval', 'avoids query avalanches');-INSERT INTO "meanings" (feature, meaning) VALUES ('type', 'is statically type-checked');-INSERT INTO "meanings" (feature, meaning) VALUES ('SQL', 'guarantees translation to SQL');--ALTER TABLE ONLY "facilities"-    ADD CONSTRAINT "facilities_pkey" PRIMARY KEY (facility);--ALTER TABLE ONLY "features"-    ADD CONSTRAINT "features_pkey" PRIMARY KEY (facility, feature);--ALTER TABLE ONLY "meanings"-    ADD CONSTRAINT "meanings_pkey" PRIMARY KEY (feature);--ALTER TABLE ONLY "features"-    ADD CONSTRAINT "foreign facility" FOREIGN KEY (facility) REFERENCES "facilities"(facility);--ALTER TABLE ONLY "features"-    ADD CONSTRAINT "foreign feature" FOREIGN KEY (feature) REFERENCES "meanings"(feature);
− examples/Example2.hs 
@@ -1,37 +0,0 @@--- This example was taken from the paper called "Comprehensive Comprehensions"--- by Phil Wadler and Simon Peyton Jones--{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}--module Main where--import Prelude ()-import Database.DSH-import Database.DSH.Compiler--import Database.HDBC.PostgreSQL--employees :: Q [(Text, Text, Integer)]-employees = toQ [-    ("Simon",  "MS",   80)-  , ("Erik",   "MS",   90)-  , ("Phil",   "Ed",   40)-  , ("Gordon", "Ed",   45)-  , ("Paul",   "Yale", 60)-  ]--query :: Q [(Text, Integer)]-query = [qc| tuple (the dept, sum salary)-           | (name, dept, salary) <- employees-          , then group by dept-          , then sortWith by (sum salary)-          , then take 5 |]--getConn :: IO Connection-getConn = connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'"--main :: IO ()-main = do-  conn   <- getConn-  result <- fromQ conn query-  print result
src/Database/DSH.hs view
@@ -25,15 +25,13 @@   , TA, table, tableDB, tableCSV, tableWithKeys, BasicType   , View, view, fromView, tuple, record -    -- * Quasiquoter-  , qc-     -- * Template Haskell: Creating Table Representations   , generateRecords   , generateInstances    , module Database.DSH.CSV +  , module Data.String   , module Data.Text   , module Database.HDBC   , module Prelude@@ -41,12 +39,12 @@   where  import Database.DSH.Data (Q, QA, TA, table, tableDB, tableCSV, tableWithKeys, BasicType, View, view, fromView, tuple, record)-import Database.DSH.QQ (qc) import Database.DSH.TH (generateRecords, generateInstances)-import Database.DSH.CSV (csvExport, csvExportHandle, csvExportStdout)+import Database.DSH.CSV (csvExport)  import Database.DSH.Combinators +import Data.String(IsString,fromString) import Data.Text (Text) import Database.HDBC @@ -98,4 +96,6 @@   , snd   , maybe   , either+  , return+  , (>>=)   )
src/Database/DSH/CSV.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, RelaxedPolyRec, OverloadedStrings #-} -module Database.DSH.CSV (csvImport, csvExport, csvExportHandle, csvExportStdout) where+module Database.DSH.CSV (csvImport, csvExport) where  import Database.DSH.Data import Database.DSH.Impossible@@ -10,17 +10,8 @@ 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+csvExport :: (TA a) => FilePath -> [a] -> IO ()+csvExport file as = T.writeFile file csvContent   where csvContent :: Text         csvContent = T.unlines (map (toRow . toNorm) as) @@ -35,7 +26,7 @@          toRow :: Norm -> Text         toRow e = case e of-                    ListN _ _       -> "Nesting"+                    ListN _ _       -> $impossible                     UnitN _         -> quote "()"                     BoolN b _       -> quote (T.pack (show b))                     CharN c _       -> quote (escape (T.singleton c))
src/Database/DSH/Combinators.hs view
@@ -326,7 +326,18 @@ 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++mzip :: (QA a, QA b) => Q [a] -> Q [b] -> Q [(a,b)]+mzip = zip++ infixl 9 !! infixr 5 ><, <|, |> infix  4  ==, /=, <, <=, >=, >@@ -336,9 +347,9 @@  -- 'QA', 'TA' and 'View' instances for tuples up to the defined length. -$(generateDeriveTupleQARange   3 16)-$(generateDeriveTupleTARange   3 16)-$(generateDeriveTupleViewRange 3 16)+$(generateDeriveTupleQARange   3 8)+$(generateDeriveTupleTARange   3 8)+$(generateDeriveTupleViewRange 3 8)   -- * Missing Combinators
− src/Database/DSH/QQ.hs 
@@ -1,333 +0,0 @@-{-# LANGUAGE TemplateHaskell, ViewPatterns #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}--module Database.DSH.QQ (qc) where--import Paths_DSH as DSH-import Database.DSH.Impossible--import Language.Haskell.SyntaxTrees.ExtsToTH (translateExtsToTH)--import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Syntax as TH-import qualified Language.Haskell.TH.Quote as TH--import Language.Haskell.Exts--import Control.Monad-import Control.Monad.State-import Control.Applicative--import Data.Generics--import qualified Data.List as L-import Data.Version (showVersion)--combinatorMod :: ModuleName-combinatorMod = ModuleName "Database.DSH"--dataMod :: ModuleName-dataMod = ModuleName "Database.DSH"--{--N monad, version of the state monad that can provide fresh variable names.--}-newtype N a = N (State Int a)--unwrapN :: N a -> State Int a-unwrapN (N s) = s--instance Functor N where-    fmap f a = N $ fmap f $ unwrapN a--instance Monad N where-    s >>= m = N (unwrapN s >>= unwrapN . m)-    return = N . return--instance Applicative N where-  pure  = return-  (<*>) = ap--freshVar :: N String-freshVar = N $ do-                i <- get-                put (i + 1)-                return $ "ferryFreshNamesV" ++ show i--runN :: N a -> a-runN = fst . (flip runState 1) . unwrapN---quoteListCompr :: String -> TH.ExpQ-quoteListCompr = transform . parseCompr--transform :: Exp -> TH.ExpQ-transform e = case translateExtsToTH . runN $ translateListCompr e of-                Left err -> error $ show err-                Right e1 -> return $ globalQuals e1--parseCompr :: String -> Exp-parseCompr = fromParseResult . exprParser--ferryParseMode :: ParseMode-ferryParseMode = defaultParseMode {-    extensions = [TransformListComp, ViewPatterns]-  , fixities = let v = case fixities defaultParseMode of-                            Nothing -> [] -                            Just x -> x-                in Just $ v ++ infix_ 0 ["?"] ++ infixr_ 5 ["><", "<|", "|>"]-  }--exprParser :: String -> ParseResult Exp-exprParser = parseExpWithMode ferryParseMode . expand--expand :: String -> String-expand e = '[':(e ++ "]")--ferryHaskell :: TH.QuasiQuoter-ferryHaskell = TH.QuasiQuoter {TH.quoteExp = quoteListCompr}--qc :: TH.QuasiQuoter-qc = ferryHaskell--fp :: TH.QuasiQuoter-fp = TH.QuasiQuoter {TH.quoteExp = (return . TH.LitE . TH.StringL . show . parseCompr)}--rw :: TH.QuasiQuoter-rw = TH.QuasiQuoter {TH.quoteExp = (return . TH.LitE . TH.StringL . show . translateExtsToTH . runN . translateListCompr . parseCompr)}--translateListCompr :: Exp -> N Exp-translateListCompr (ListComp e q) = do-                                     let pat = variablesFromLst $ reverse q-                                     lambda <- makeLambda pat (SrcLoc "" 0 0) e-                                     (mapF lambda) <$> normaliseQuals q-translateListCompr (ParComp e qs) = do-                                     let pat = variablesFromLsts qs-                                     lambda <- makeLambda pat (SrcLoc "" 0 0) e-                                     (mapF lambda) <$> normParallelCompr qs-translateListCompr l              = error $ "Expr not supported by Ferry: " ++ show l---- Transforming qualifiers----normParallelCompr :: [[QualStmt]] -> N Exp-normParallelCompr [] = $impossible-normParallelCompr [x] = normaliseQuals x-normParallelCompr (x:xs) = zipF <$> (normaliseQuals x) <*> (normParallelCompr xs)---normaliseQuals :: [QualStmt] -> N Exp-normaliseQuals = normaliseQuals' . reverse--normaliseQuals' :: [QualStmt] -> N Exp-normaliseQuals' ((ThenTrans e):ps) = paren . (app e) <$> normaliseQuals' ps-normaliseQuals' ((ThenBy ef ek):ps) = do-                                        let pv = variablesFromLst ps-                                        ks <- makeLambda pv (SrcLoc "" 0 0) ek-                                        app (app ef ks) <$> normaliseQuals' ps-normaliseQuals' ((GroupBy e):ps)    = normaliseQuals' ((GroupByUsing e groupWithF):ps)-normaliseQuals' ((GroupByUsing e f):ps) = do-                                            let pVar = variablesFromLst ps-                                            lambda <- makeLambda pVar (SrcLoc "" 0 0) e-                                            unzipped <- unzipB pVar-                                            (\x -> mapF unzipped (app (app f lambda) x)) <$> normaliseQuals' ps-normaliseQuals' ((GroupUsing e):ps) = let pVar = variablesFromLst ps-                                       in mapF <$> unzipB pVar <*> (app e <$> normaliseQuals' ps)-normaliseQuals' [q]    = normaliseQual q-normaliseQuals' []     = pure $ consF unit nilF-normaliseQuals' (q:ps) = do-                          qn <- normaliseQual q-                          let qv = variablesFrom q-                          pn <- normaliseQuals' ps-                          let pv = variablesFromLst ps-                          combine pn pv qn qv--normaliseQual :: QualStmt -> N Exp-normaliseQual (QualStmt (Generator _ _ e)) = pure $ e-normaliseQual (QualStmt (Qualifier e)) = pure $ boolF nilF (consF unit nilF)  e-normaliseQual (QualStmt (LetStmt (BDecls bi@[PatBind _ p _ _ _]))) = pure $ flip consF nilF $ letE bi $ patToExp p-normaliseQual _ = $impossible--combine :: Exp -> Pat -> Exp -> Pat -> N Exp-combine p pv q qv = do-                     qLambda <- makeLambda qv (SrcLoc "" 0 0) $ fromViewF (tuple [patToExp qv, patToExp pv])-                     pLambda <- makeLambda pv (SrcLoc "" 0 0) $ mapF qLambda q-                     pure $ concatF (mapF pLambda p)--unzipB :: Pat -> N Exp-unzipB PWildCard   = paren <$> makeLambda PWildCard (SrcLoc "" 0 0) unit-unzipB p@(PVar x)  = paren <$> makeLambda p (SrcLoc "" 0 0) (var x)-unzipB (PTuple [xp, yp]) = do-                              e <- freshVar-                              let ePat = patV e-                              let eArg = varV e-                              xUnfold <- unzipB xp-                              yUnfold <- unzipB yp-                              (<$>) paren $ makeLambda ePat (SrcLoc "" 0 0) $-                                             fromViewF $ tuple [app xUnfold $ paren $ mapF fstV eArg, app yUnfold $ mapF sndV eArg]-unzipB (PTuple ps) = do-                        let pl = length ps-                        e <- freshVar-                        let ePat = patV e-                        let eArg = varV e-                        ps' <- mapM (\_ -> freshVar) ps-                        ups <- mapM unzipB ps-                        views <- mapM (viewN ps') [0..(pl-1)]--                        (<$>) paren $ makeLambda ePat (SrcLoc "" 0 0) $-                                            fromViewF $ tuple [app unf $ paren $ mapF proj eArg | (unf, proj) <- zip ups views]--unzipB _ = $impossible--viewN :: [String] -> Int -> N Exp-viewN ps i = let e = varV $ ps !! i-                 pat = PTuple $ map patV ps-              in makeLambda pat (SrcLoc "" 0 0) e--patV :: String -> Pat-patV = PVar . name--varV :: String -> Exp-varV = var . name---- Building and converting patterns---variablesFromLsts :: [[QualStmt]] -> Pat-variablesFromLsts [] = $impossible-variablesFromLsts [x]    = variablesFromLst $ reverse x-variablesFromLsts (x:xs) = PTuple [variablesFromLst $ reverse x, variablesFromLsts xs]--variablesFromLst :: [QualStmt] -> Pat-variablesFromLst ((ThenTrans _):xs) = variablesFromLst xs-variablesFromLst ((ThenBy _ _):xs) = variablesFromLst xs-variablesFromLst ((GroupBy _):xs) = variablesFromLst xs-variablesFromLst ((GroupUsing _):xs) = variablesFromLst xs-variablesFromLst ((GroupByUsing _ _):xs) = variablesFromLst xs-variablesFromLst [x]    = variablesFrom x-variablesFromLst (x:xs) = PTuple [variablesFrom x, variablesFromLst xs]-variablesFromLst []     = PWildCard--variablesFrom :: QualStmt -> Pat-variablesFrom (QualStmt (Generator _ p _)) = p-variablesFrom (QualStmt (Qualifier _)) = PWildCard-variablesFrom (QualStmt (LetStmt (BDecls [PatBind _ p _ _ _]))) = p-variablesFrom (QualStmt e)  = error $ "Not supported yet: " ++ show e-variablesFrom _ = $impossible--makeLambda :: Pat -> SrcLoc -> Exp -> N Exp-makeLambda p s b = do-                     (p', e') <- mkViewPat p b-                     pure $ Lambda s [p'] e'---mkViewPat :: Pat -> Exp -> N (Pat, Exp)-mkViewPat p@(PVar _)  e = return $ (p, e)-mkViewPat PWildCard   e = return $ (PWildCard, e)-mkViewPat (PTuple ps) e = do-                               x <- freshVar-                               (pr, e') <- foldl viewTup (pure $ ([], e)) ps-                               let px = PVar $ name x-                               let vx = var $ name x-                               let er = caseE (app viewV vx) [alt (SrcLoc "" 0 0) (PTuple $ reverse pr) e']-                               return (px, er)--mkViewPat (PList ps)  e = do-                            x <- freshVar-                            let px = PVar $ name x-                            let vx = var $ name x-                            let er = caseE (app viewV vx) [alt (SrcLoc "" 0 0) (PList ps) e]-                            return (px, er)-mkViewPat (PParen p)  e = do-                            (p', e') <- mkViewPat p e-                            return (PParen p', e')-mkViewPat p           e = do-                            x <- freshVar-                            let px = PVar $ name x-                            let vx = var $ name x-                            let er = caseE (app viewV vx) [alt (SrcLoc "" 0 0) p e]-                            return (px, er)--viewTup :: N ([Pat], Exp) -> Pat -> N ([Pat], Exp)-viewTup r p = do-                    (rp, re) <- r-                    (p', e') <- mkViewPat p re-                    return (p':rp, e')--viewV :: Exp-viewV = var $ name $ "view"--patToExp :: Pat -> Exp-patToExp (PVar x)                    = var x-patToExp (PTuple ps)                 = fromViewF $ tuple $ map patToExp ps-patToExp (PApp (Special UnitCon) []) = unit-patToExp PWildCard                   = unit-patToExp p                           = error $ "Pattern not suppoted by ferry: " ++ show p---- Ferry Combinators--fstV :: Exp-fstV = qvar combinatorMod $ name "fst"--sndV :: Exp-sndV = qvar combinatorMod $ name "snd"--mapV :: Exp-mapV = qvar combinatorMod $ name "map"--mapF :: Exp -> Exp -> Exp-mapF f l = flip app l $ app mapV f--unit :: Exp-unit = qvar combinatorMod $ name "unit"--consF :: Exp -> Exp -> Exp-consF hd tl = flip app tl $ app consV hd--nilF :: Exp-nilF = nilV--nilV :: Exp-nilV = qvar combinatorMod $ name "nil"--consV :: Exp-consV = qvar combinatorMod $ name "cons"--fromViewV :: Exp-fromViewV = qvar dataMod $ name "fromView"--fromViewF :: Exp -> Exp-fromViewF e1 =  app fromViewV e1--concatF :: Exp -> Exp-concatF = app concatV--concatV :: Exp-concatV = qvar combinatorMod $ name "concat"--boolF :: Exp -> Exp -> Exp -> Exp-boolF t e c = app (app ( app (qvar combinatorMod $ name "bool") t) e) c--groupWithF :: Exp-groupWithF = qvar combinatorMod $ name "groupWith"--zipV :: Exp-zipV = qvar combinatorMod $ name "zip"--zipF :: Exp -> Exp -> Exp-zipF x y = app (app zipV x) y----- Generate proper global names from pseudo qualified variables-toNameG :: TH.Name -> TH.Name-toNameG n@(TH.Name (TH.occString -> occN) (TH.NameQ (TH.modString -> m))) =-  if "database" `L.isPrefixOf` m-      then let pkgN = "DSH-" ++ showVersion (DSH.version)-               modN = "Database"  ++ (drop 8 m)-            in TH.mkNameG_v pkgN modN occN-      else n-toNameG n = n--globalQuals :: TH.Exp -> TH.Exp-globalQuals = everywhere (mkT toNameG)