diff --git a/DSH.cabal b/DSH.cabal --- a/DSH.cabal +++ b/DSH.cabal @@ -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 diff --git a/examples/Example01.hs b/examples/Example01.hs new file mode 100644 --- /dev/null +++ b/examples/Example01.hs @@ -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 diff --git a/examples/Example1.hs b/examples/Example1.hs deleted file mode 100644 --- a/examples/Example1.hs +++ /dev/null @@ -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 diff --git a/examples/Example1_data.sql b/examples/Example1_data.sql deleted file mode 100644 --- a/examples/Example1_data.sql +++ /dev/null @@ -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); diff --git a/examples/Example2.hs b/examples/Example2.hs deleted file mode 100644 --- a/examples/Example2.hs +++ /dev/null @@ -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 diff --git a/src/Database/DSH.hs b/src/Database/DSH.hs --- a/src/Database/DSH.hs +++ b/src/Database/DSH.hs @@ -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 + , (>>=) ) 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,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)) diff --git a/src/Database/DSH/Combinators.hs b/src/Database/DSH/Combinators.hs --- a/src/Database/DSH/Combinators.hs +++ b/src/Database/DSH/Combinators.hs @@ -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 diff --git a/src/Database/DSH/QQ.hs b/src/Database/DSH/QQ.hs deleted file mode 100644 --- a/src/Database/DSH/QQ.hs +++ /dev/null @@ -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)