module Database.Narc (
NarcTerm,
narcToSQL, narcToSQLString,
unit, table, cnst, Constable, primApp, abs, app, ifthenelse, singleton,
nil, union, record, project, foreach, having,
Type(..)
) where
import Prelude hiding (abs, catch)
import Control.Exception (catch, throwIO, evaluate, SomeException)
import Control.Monad.State hiding (when, join)
import Control.Monad.Error (throwError, runErrorT, Error(..))
import Data.List (nub, (\\), sort, sortBy, groupBy, intersperse)
import Data.Maybe (fromJust, isJust, fromMaybe)
import Control.Applicative ((<$>), (<*>))
import Foreign (unsafePerformIO)
import Test.QuickCheck hiding (promote, Failure)
import QCUtils
import Test.HUnit hiding (State, assert)
import Debug.Trace
import Gensym
import Database.Narc.AST
import Database.Narc.Common
import Database.Narc.Compile
import Database.Narc.Debug
import Database.Narc.Eval
import Database.Narc.Failure
import Database.Narc.Pretty
import Database.Narc.AST.Pretty
import Database.Narc.SQL.Pretty
import qualified Database.Narc.SQL as SQL
import Database.Narc.Type as Type
import Database.Narc.TypeInfer
import Database.Narc.Util
import Database.Narc.HDBC
typeCheckAndCompile :: Term a -> SQL.Query
typeCheckAndCompile = compile [] . runTyCheck []
example_dull = (Comp "x" (Table "foo" [("a", TBool)], ())
(If (Project (Var "x", ()) "a", ())
(Singleton (Var "x", ()), ())
(Nil, ()), ()), ())
type NarcTerm = Gensym (Term ())
narcToSQLString :: NarcTerm -> String
narcToSQLString = SQL.serialize . narcToSQL
narcToSQL :: NarcTerm -> SQL.Query
narcToSQL = typeCheckAndCompile . realize
realize :: NarcTerm -> Term ()
realize = runGensym
unit :: NarcTerm
unit = return $ (!) Unit
class Constable a where
cnst :: a -> NarcTerm
instance Constable Bool where cnst b = return ((!)(Bool b))
instance Constable Integer where cnst n = return ((!)(Num n))
primApp :: String -> [NarcTerm] -> NarcTerm
primApp f args = (!) . PrimApp f <$> sequence args
abs :: (String -> NarcTerm) -> NarcTerm
abs fn = do
n <- gensym
let x = '_' : show n
body <- fn x
return $ (!) $ Abs x body
app :: NarcTerm -> NarcTerm -> NarcTerm
app l m = (!) <$> (App <$> l <*> m)
table :: Tabname -> [(Field, Type)] -> NarcTerm
table tbl ty = return $ (!) $ Table tbl ty
ifthenelse :: NarcTerm -> NarcTerm -> NarcTerm -> NarcTerm
ifthenelse c t f = (!) <$> (If <$> c <*> t <*> f)
singleton :: NarcTerm -> NarcTerm
singleton x = (!) . Singleton <$> x
nil :: NarcTerm
nil = return $ (!) $ Nil
union :: NarcTerm -> NarcTerm -> NarcTerm
union l r = (!) <$> (Union <$> l <*> r)
record :: [(String, NarcTerm)] -> NarcTerm
record fields = (!) <$> (Record <$> sequence [do expr' <- expr ; return (lbl, expr') | (lbl, expr) <- fields])
project :: NarcTerm -> String -> NarcTerm
project expr field = (!) <$> (Project <$> expr <*> return field)
foreach :: NarcTerm -> (NarcTerm -> NarcTerm) -> NarcTerm
foreach src k = do
src' <- src
n <- gensym
let x = '_' : show n
body' <- k (return (var_ x))
return $ (!)(Comp x src' body')
having :: NarcTerm -> NarcTerm -> NarcTerm
having cond body = ifthenelse cond body nil