packages feed

relational-query 0.10.0.1 → 0.10.1.0

raw patch · 23 files changed

+810/−419 lines, 23 filesdep ~names-th

Dependency ranges changed: names-th

Files

ChangeLog.md view
@@ -1,8 +1,9 @@ <!-- -*- Markdown -*- --> -## 0.10.0.1+## 0.10.1.0 -- backport fix of fromMaybe record width.+- add overloaded projections.+- add a portable sequence number operation.  ## 0.10.0.0
relational-query.cabal view
@@ -1,5 +1,5 @@ name:                relational-query-version:             0.10.0.1+version:             0.10.1.0 synopsis:            Typeful, Modular, Relational, algebraic query engine description:         This package contiains typeful relation structure and                      relational-algebraic query building DSL which can@@ -43,7 +43,8 @@                        Database.Relational.Record                        Database.Relational.ProjectableClass                        Database.Relational.Projectable-                       Database.Relational.ProjectableExtended+                       Database.Relational.Projectable.Unsafe+                       Database.Relational.Projectable.Instances                        Database.Relational.TupleInstances                        Database.Relational.Monad.BaseType                        Database.Relational.Monad.Class@@ -62,17 +63,21 @@                        Database.Relational.Monad.Register                        Database.Relational.Relation                        Database.Relational.Set+                       Database.Relational.Sequence                        Database.Relational.Effect                        Database.Relational.Scalar                        Database.Relational.Type                        Database.Relational.Derives-                       Database.Relational.BaseTH                        Database.Relational.TH                         Database.Relational.Compat                        Database.Relational.Query                        Database.Relational.Query.Arrow +                       -- for GHC version equal or more than 8.0+                       Database.Relational.OverloadedProjection+                       Database.Relational.OverloadedInstances+   other-modules:                        Database.Relational.Internal.ContextType                        Database.Relational.Internal.Config@@ -86,6 +91,10 @@                        Database.Relational.SqlSyntax.Updates                        Database.Relational.Monad.Trans.JoinState                        Database.Relational.Monad.Trans.Qualify+                       Database.Relational.InternalTH.Base++                       -- for GHC version equal or more than 8.0+                       Database.Relational.InternalTH.Overloaded    build-depends:         base <5                        , array
src/Database/Relational.hs view
@@ -19,7 +19,6 @@   module Database.Relational.Record,   module Database.Relational.ProjectableClass,   module Database.Relational.Projectable,-  module Database.Relational.ProjectableExtended,   module Database.Relational.TupleInstances,   module Database.Relational.Monad.BaseType,   module Database.Relational.Monad.Class,@@ -35,6 +34,7 @@   module Database.Relational.Monad.Register,   module Database.Relational.Relation,   module Database.Relational.Set,+  module Database.Relational.Sequence,   module Database.Relational.Scalar,   module Database.Relational.Type,   module Database.Relational.Effect,@@ -59,7 +59,6 @@ import Database.Relational.Record (RecordList, list) import Database.Relational.ProjectableClass import Database.Relational.Projectable-import Database.Relational.ProjectableExtended import Database.Relational.TupleInstances import Database.Relational.Monad.BaseType import Database.Relational.Monad.Class@@ -83,6 +82,7 @@ import Database.Relational.Monad.Register (Register) import Database.Relational.Relation import Database.Relational.Set+import Database.Relational.Sequence import Database.Relational.Scalar (ScalarDegree) import Database.Relational.Type hiding   (unsafeTypedKeyUpdate, unsafeTypedDelete,
− src/Database/Relational/BaseTH.hs 
@@ -1,76 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ConstraintKinds #-}---- |--- Module      : Database.Relational.BaseTH--- Copyright   : 2017 Kei Hibino--- License     : BSD3------ Maintainer  : ex8k.hibino@gmail.com--- Stability   : experimental--- Portability : unknown------ This module defines templates for internally using.-module Database.Relational.BaseTH (-  defineTupleShowConstantInstance,-  defineTuplePi,--  defineRecordProjections,-  ) where--import Control.Applicative ((<$>))-import Data.List (foldl', inits)-import Language.Haskell.TH-  (Q, Name, mkName, normalB, classP, varP,-   TypeQ, forallT, varT, tupleT, appT,-   Dec, sigD, valD, instanceD,-   TyVarBndr (PlainTV), )-import Database.Record.Persistable-  (PersistableWidth, persistableWidth,-   PersistableRecordWidth, runPersistableRecordWidth)--import Database.Relational.ProjectableClass (ShowConstantTermsSQL (..))-import Database.Relational.Pi.Unsafe (Pi, definePi)---tupleN :: Int -> (([Name], [TypeQ]), TypeQ)-tupleN n = ((ns, vs), foldl' appT (tupleT n) vs)-  where-    ns = [ mkName $ "a" ++ show j | j <- [1 .. n] ]-    vs = map varT ns---- | Make template of 'ShowConstantTermsSQL' instance of tuple type.-defineTupleShowConstantInstance :: Int -> Q [Dec]-defineTupleShowConstantInstance n = do-  let ((_, vs), tty)  =  tupleN n-  (:[]) <$> instanceD-    -- in template-haskell 2.8 or older, Pred is not Type-    (mapM (classP ''ShowConstantTermsSQL . (:[])) vs)-    [t| ShowConstantTermsSQL $tty |]-    []---- | Make polymorphic projection templates.-defineRecordProjections :: TypeQ -> [Name] -> [Name] -> [TypeQ] -> Q [Dec]-defineRecordProjections tyRec avs sels cts =-    fmap concat . sequence $ zipWith3 template cts (inits cts) sels-  where-    template :: TypeQ -> [TypeQ] -> Name -> Q [Dec]-    template ct pcts selN = do-      sig <- sigD selN $-             forallT (map PlainTV avs)-             (mapM (classP ''PersistableWidth . (:[]) . varT) avs)-             [t| Pi $tyRec $ct |]-      let runPW t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]-      val <- valD (varP selN)-             (normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) |]) [| 0 :: Int |] pcts) |]) []-      return [sig, val]---- | Make templates of projection paths for tuple types.-defineTuplePi :: Int -> Q [Dec]-defineTuplePi n =-  defineRecordProjections tyRec avs sels cts-  where-    ((avs, cts), tyRec) = tupleN n-    sels = [ mkName $ "tuplePi" ++ show n ++ "_" ++ show i ++ "'"-           | i <- [ 0 .. n - 1] ]
src/Database/Relational/Compat.hs view
@@ -104,6 +104,7 @@   unsafeProjectSqlTerms = Projectable.unsafeProjectSqlTerms  {-# DEPRECATED unsafeProjectSql "Use Database.Relational.unsafeProjectSql instead of this." #-}+-- | Deprecated. Use Database.Relational.unsafeProjectSql instead of this. unsafeProjectSql :: SqlProjectable p => String -> p a unsafeProjectSql = unsafeProjectSqlTerms . (:[]) . stringSQL @@ -117,5 +118,6 @@   unsafeShowSql' = Record.unsafeStringSql  {-# DEPRECATED unsafeShowSql "Use Database.Relational.unsafeShowSql instead of this." #-}+-- | Deprecated. Use Database.Relational.unsafeShowSql instead of this. unsafeShowSql :: ProjectableShowSql p => p a -> String unsafeShowSql = showStringSQL . unsafeShowSql'
src/Database/Relational/Derives.hs view
@@ -36,8 +36,7 @@ import Database.Relational.Table (Table, TableDerivable) import Database.Relational.Pi.Unsafe (Pi, unsafeExpandIndexes) import qualified Database.Relational.Record as Record-import Database.Relational.Projectable (placeholder, (.=.))-import Database.Relational.ProjectableExtended ((!))+import Database.Relational.Projectable (placeholder, (.=.), (!)) import Database.Relational.Monad.Class (wheres) import Database.Relational.Monad.BaseType (Relation, relationWidth) import Database.Relational.Relation
src/Database/Relational/Internal/Config.hs view
@@ -16,6 +16,8 @@          , schemaNameMode          , normalizedTableName          , verboseAsCompilerWarning+         , disableOverloadedProjection+         , disableSpecializedProjection          , identifierQuotation          , nameConfig),   defaultConfig,@@ -50,25 +52,29 @@ -- | Configuration type. data Config =   Config-  { productUnitSupport        ::  !ProductUnitSupport-  , chunksInsertSize          ::  !Int-  , schemaNameMode            ::  !SchemaNameMode-  , normalizedTableName       ::  !Bool-  , verboseAsCompilerWarning  ::  !Bool-  , identifierQuotation       ::  !IdentifierQuotation-  , nameConfig                ::  !NameConfig+  { productUnitSupport           ::  !ProductUnitSupport+  , chunksInsertSize             ::  !Int+  , schemaNameMode               ::  !SchemaNameMode+  , normalizedTableName          ::  !Bool+  , verboseAsCompilerWarning     ::  !Bool+  , disableOverloadedProjection  ::  !Bool+  , disableSpecializedProjection ::  !Bool+  , identifierQuotation          ::  !IdentifierQuotation+  , nameConfig                   ::  !NameConfig   } deriving Show  -- | Default configuration. defaultConfig :: Config defaultConfig =-  Config { productUnitSupport        =  PUSupported-         , chunksInsertSize          =  256-         , schemaNameMode            =  SchemaQualified-         , normalizedTableName       =  True-         , verboseAsCompilerWarning  =  False-         , identifierQuotation       =  NoQuotation-         , nameConfig                =  NameConfig { recordConfig     =  RecordTH.defaultNameConfig-                                                   , relationVarName  =  const varCamelcaseName+  Config { productUnitSupport            =  PUSupported+         , chunksInsertSize              =  256+         , schemaNameMode                =  SchemaQualified+         , normalizedTableName           =  True+         , verboseAsCompilerWarning      =  False+         , disableOverloadedProjection   =  False+         , disableSpecializedProjection  =  False+         , identifierQuotation           =  NoQuotation+         , nameConfig                    =  NameConfig { recordConfig     =  RecordTH.defaultNameConfig+                                                       , relationVarName  =  const varCamelcaseName                                                    }          }
+ src/Database/Relational/InternalTH/Base.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}++-- |+-- Module      : Database.Relational.InternalTH.Base+-- Copyright   : 2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines templates for internally using.+module Database.Relational.InternalTH.Base (+  defineTupleShowConstantInstance,+  defineTuplePi,++  defineRecordProjections,+  ) where++import Control.Applicative ((<$>))+import Data.List (foldl', inits)+import Language.Haskell.TH+  (Q, Name, mkName, normalB, classP, varP,+   TypeQ, forallT, varT, tupleT, appT,+   Dec, sigD, valD, instanceD,+   TyVarBndr (PlainTV), )+import Database.Record.Persistable+  (PersistableWidth, persistableWidth,+   PersistableRecordWidth, runPersistableRecordWidth)++import Database.Relational.ProjectableClass (ShowConstantTermsSQL (..))+import Database.Relational.Pi.Unsafe (Pi, definePi)+++tupleN :: Int -> (([Name], [TypeQ]), TypeQ)+tupleN n = ((ns, vs), foldl' appT (tupleT n) vs)+  where+    ns = [ mkName $ "a" ++ show j | j <- [1 .. n] ]+    vs = map varT ns++-- | Make template of 'ShowConstantTermsSQL' instance of tuple type.+defineTupleShowConstantInstance :: Int -> Q [Dec]+defineTupleShowConstantInstance n = do+  let ((_, vs), tty)  =  tupleN n+  (:[]) <$> instanceD+    -- in template-haskell 2.8 or older, Pred is not Type+    (mapM (classP ''ShowConstantTermsSQL . (:[])) vs)+    [t| ShowConstantTermsSQL $tty |]+    []++-- | Make polymorphic projection templates.+defineRecordProjections :: TypeQ -> [Name] -> [Name] -> [TypeQ] -> Q [Dec]+defineRecordProjections tyRec avs sels cts =+    fmap concat . sequence $ zipWith3 template cts (inits cts) sels+  where+    template :: TypeQ -> [TypeQ] -> Name -> Q [Dec]+    template ct pcts selN = do+      sig <- sigD selN $+             forallT (map PlainTV avs)+             (mapM (classP ''PersistableWidth . (:[]) . varT) avs)+             [t| Pi $tyRec $ct |]+      let runPW t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]+      val <- valD (varP selN)+             (normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) :: Int |]) [| 0 :: Int |] pcts) |]) []+      return [sig, val]++-- | Make templates of projection paths for tuple types.+defineTuplePi :: Int -> Q [Dec]+defineTuplePi n =+  defineRecordProjections tyRec avs sels cts+  where+    ((avs, cts), tyRec) = tupleN n+    sels = [ mkName $ "tuplePi" ++ show n ++ "_" ++ show i ++ "'"+           | i <- [ 0 .. n - 1] ]
+ src/Database/Relational/InternalTH/Overloaded.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module      : Database.Relational.InternalTH.Overloaded+-- Copyright   : 2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines overloaded projection templates for internally using.+module Database.Relational.InternalTH.Overloaded (+  monomorphicProjection,+  polymorphicProjections,+  tupleProjection,+  ) where++#if __GLASGOW_HASKELL__ >= 800+import Language.Haskell.TH+  (Name, mkName, Q, TypeQ, Dec, instanceD, funD, classP,+   appT, tupleT, varT, litT, strTyLit, clause, normalB)+import Language.Haskell.TH.Lib.Extra (integralE)+import Language.Haskell.TH.Name.CamelCase+  (ConName, conName, toVarExp, toTypeCon)+import Data.List (foldl', inits)+import Data.Array ((!))+import Database.Record.Persistable+  (PersistableWidth, persistableWidth,+   PersistableRecordWidth, runPersistableRecordWidth)+import Database.Record.TH (columnOffsetsVarNameDefault)++import Database.Relational.Pi.Unsafe (definePi)+import Database.Relational.OverloadedProjection (HasProjection (projection))+#else+import Language.Haskell.TH (Name, mkName, Q, TypeQ, appT, tupleT, varT, Dec)+import Language.Haskell.TH.Name.CamelCase (ConName)+import Data.List (foldl')+#endif++-- | Projection template for monomorphic record type.+monomorphicProjection :: ConName+                      -> String+                      -> Int+                      -> TypeQ+                      -> Q [Dec]+#if __GLASGOW_HASKELL__ >= 800+monomorphicProjection recName colStr ix colType =+    [d| instance HasProjection $(litT $ strTyLit colStr) $(toTypeCon recName) $colType where+          projection _ = definePi $ $offsetsExp ! $(integralE ix)+      |]+  where+    offsetsExp = toVarExp . columnOffsetsVarNameDefault $ conName recName+#else+monomorphicProjection _ _ _ _ = [d| |]+#endif++-- | Projection templates for record type with type variable.+polymorphicProjections :: TypeQ+                       -> [Name]+                       -> [String]+                       -> [TypeQ]+                       -> Q [Dec]+#if __GLASGOW_HASKELL__ >= 800+polymorphicProjections recType avs sels cts =+    sequence $ zipWith3 template sels cts (inits cts)+  where+    template colStr colType pcts =+      instanceD+      (mapM (classP ''PersistableWidth . (:[]) . varT) avs)+      [t| HasProjection $(litT $ strTyLit colStr) $recType $colType |]+      [projectionDec pcts]++projectionDec :: [TypeQ] -> Q Dec+projectionDec cts =+    funD+    (mkName "projection")+    [clause [[p| _ |]]+      (normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) |]) [| 0 :: Int |] cts) |])+      []]+  --- In sub-tree, newName "projection" is called by [d| projection .. = |]?+  --- head <$> [d| projection _ =  definePi $(foldl' (\e t -> [| $e + $(runPW t) |]) [| 0 :: Int |] cts) |]+  where+    runPW t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]+#else+polymorphicProjections _ _ _ _ = [d| |]+#endif++-- | Projection templates for tuple type.+tupleProjection :: Int -> Q [Dec]+tupleProjection n =+    polymorphicProjections tyRec avs sels cts+  where+    sels = [ "tuplePi" ++ show n ++ "_" ++ show i+           | i <- [ 0 .. n - 1] ]+    ((avs, cts), tyRec) = tupleN+    tupleN :: (([Name], [TypeQ]), TypeQ)+    --- same as tupleN of InternalTH.Base, merge after dropping GHC 7.x+    tupleN = ((ns, vs), foldl' appT (tupleT n) vs)+      where+        ns = [ mkName $ "a" ++ show j | j <- [1 .. n] ]+        vs = map varT ns
+ src/Database/Relational/OverloadedInstances.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}++-- |+-- Module      : Database.Relational.OverloadedInstances+-- Copyright   : 2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides basic instances of overloaded projections like tuples..+module Database.Relational.OverloadedInstances () where++import Control.Applicative ((<$>))+#if __GLASGOW_HASKELL__ >= 800+import Database.Record.Persistable+  (PersistableWidth, persistableWidth,+   PersistableRecordWidth, runPersistableRecordWidth)++import Database.Relational.Pi.Unsafe (definePi)+import Database.Relational.OverloadedProjection (HasProjection (projection))+#endif+import Database.Relational.InternalTH.Overloaded (tupleProjection)+++$(concat <$> mapM tupleProjection [2 .. 7])+-- Generic instances of tuple types are generated from 2 to 7 in GHC.Generics.++#if __GLASGOW_HASKELL__ >= 800+instance PersistableWidth a =>+         HasProjection "fst" (a, b) a where+  projection _ = definePi 0++instance (PersistableWidth a, PersistableWidth b) =>+         HasProjection "snd" (a, b) b where+  projection _ = definePi $ runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth b)+#endif
+ src/Database/Relational/OverloadedProjection.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}++#if __GLASGOW_HASKELL__ >= 800+-- |+-- Module      : Database.Relational.OverloadedProjection+-- Copyright   : 2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides interfaces of overloaded projections.+module Database.Relational.OverloadedProjection (+  HasProjection (..),+  ) where++import GHC.OverloadedLabels (IsLabel(..))+import GHC.TypeLits (Symbol)++import Database.Record (PersistableWidth)+import Database.Relational.SqlSyntax (PI)+import Database.Relational.Pi (Pi)+import Database.Relational.Projectable ((!))+++data PiLabel (l :: Symbol) = GetPi++-- | Projection interface to implement Pi with row polymorphism.+class HasProjection l a b | l a -> b where+  projection :: PiLabel l -> Pi a b++-- | Derive 'IsLabel' instance from 'HasProjection'.+instance HasProjection l a b => IsLabel l (Pi a b) where+  fromLabel _ = projection (GetPi :: PiLabel l)++-- | Derive 'PI' label.+instance (PersistableWidth a, IsLabel l (Pi a b))+          => IsLabel l (PI c a b) where+  fromLabel s = (! fromLabel s)+#else+module Database.Relational.OverloadedProjection () where+#endif
src/Database/Relational/Pi.hs view
@@ -13,30 +13,14 @@   -- * Projection path   Pi, (<.>), (<?.>), (<?.?>), -  id', fst', snd'+  id',   ) where  import qualified Control.Category as Category-import Database.Record-  (PersistableWidth, persistableWidth, PersistableRecordWidth)-import Database.Record.Persistable-  (runPersistableRecordWidth) -import Database.Relational.Pi.Unsafe-  (Pi, (<.>), (<?.>), (<?.?>), definePi)+import Database.Relational.Pi.Unsafe (Pi, (<.>), (<?.>), (<?.?>))   -- | Identity projection path. id' :: Pi a a id' = Category.id---- | Projection path for fst of tuple.-fst' :: PersistableWidth a => Pi (a, b) a -- ^ Projection path of fst.-fst' =  definePi 0--snd'' :: PersistableWidth b => PersistableRecordWidth a -> Pi (a, b) b-snd'' wa = definePi (runPersistableRecordWidth wa)---- | Projection path for snd of tuple.-snd' :: (PersistableWidth a, PersistableWidth b) =>  Pi (a, b) b -- ^ Projection path of snd.-snd' =  snd'' persistableWidth
src/Database/Relational/Pi/Unsafe.hs view
@@ -68,14 +68,14 @@       (pbc, wc) = g $ wbf wb   in (pab `unsafePiAppend'` pbc, wcf wc) --- | Unsafely untype key to expand indexes.+-- | Unsafely expand indexes from key. unsafeExpandIndexes' :: PersistableRecordWidth a -> Pi a b -> [Int] unsafeExpandIndexes' wa (Pi f) = d $ f wa where   d (Map is, _)    = is   d (Leftest i, w) = [ i .. i + w' - 1 ]  where     w' = runPersistableRecordWidth w --- | Unsafely untype key to expand indexes.+-- | Unsafely expand indexes from key. Infered width version. unsafeExpandIndexes :: PersistableWidth a => Pi a b -> [Int] unsafeExpandIndexes = unsafeExpandIndexes' persistableWidth
src/Database/Relational/Projectable.hs view
@@ -59,14 +59,28 @@    -- * 'Maybe' type projecitoins   ProjectableMaybe (just, flattenMaybe),++  -- * Projection for nested 'Maybe's+  ProjectableFlattenMaybe (flatten),++  flattenPiMaybe,++  -- * Get narrower records+  (!), (?), (??), (?!), (?!?), (!??),++  -- * Aggregate functions+  unsafeAggregateOp,+  count,+  sum', sumMaybe, avg, avgMaybe,+  max', maxMaybe, min', minMaybe,+  every, any', some',   ) where  import Prelude hiding (pi)  import Data.String (IsString) import Data.Functor.ProductIsomorphic-  (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|),-   ProductIsoEmpty, pureE, peRight, peLeft, )+  ((|$|), ProductIsoApplicative, pureP, (|*|), )  import Language.SQL.Keyword (Keyword) import qualified Language.SQL.Keyword as SQL@@ -76,41 +90,21 @@    HasColumnConstraint, NotNull) import Database.Record.Persistable (runPersistableRecordWidth) -import Database.Relational.Internal.ContextType-  (Flat, Aggregated, Exists, OverWindow)+import Database.Relational.Internal.ContextType (Flat, Exists, OverWindow) import Database.Relational.Internal.String (StringSQL, stringSQL, showStringSQL) import Database.Relational.SqlSyntax (Record, Predicate) import qualified Database.Relational.SqlSyntax as Syntax  import Database.Relational.Pure () import Database.Relational.TupleInstances ()+import Database.Relational.Pi (Pi) import Database.Relational.ProjectableClass   (ShowConstantTermsSQL, showConstantTermsSQL, ) import Database.Relational.Record (RecordList) import qualified Database.Relational.Record as Record----- | Interface to project SQL terms unsafely.-class SqlContext c where-  -- | Unsafely project from SQL expression terms.-  unsafeProjectSqlTerms :: [StringSQL]-                        -> Record c t---- | Unsafely make 'Record' from SQL terms.-instance SqlContext Flat where-  unsafeProjectSqlTerms = Record.unsafeFromSqlTerms---- | Unsafely make 'Record' from SQL terms.-instance SqlContext Aggregated where-  unsafeProjectSqlTerms = Record.unsafeFromSqlTerms---- | Unsafely make 'Record' from SQL terms.-instance SqlContext OverWindow where-  unsafeProjectSqlTerms = Record.unsafeFromSqlTerms--class SqlContext c => OperatorContext c-instance OperatorContext Flat-instance OperatorContext Aggregated+import Database.Relational.Projectable.Unsafe+  (SqlContext (..), OperatorContext, AggregatedContext, PlaceHolders (..))+import Database.Relational.Projectable.Instances ()   -- | Unsafely Project single SQL term.@@ -306,7 +300,7 @@  unsafeCastProjectable :: SqlContext c                       => Record c a -> Record c b-unsafeCastProjectable = Syntax.record . Syntax.untypeRecord+unsafeCastProjectable = unsafeProjectSql' . unsafeShowSql'  -- | Number fromIntegral uni-operator. fromIntegral' :: (SqlContext c, Integral a, Num b)@@ -443,9 +437,6 @@ cumeDist :: Record OverWindow Double cumeDist =  unsafeUniTermFunction SQL.CUME_DIST --- | Placeholder parameter type which has real parameter type arguemnt 'p'.-data PlaceHolders p = PlaceHolders- -- | Unsafely add placeholder parameter to queries. unsafeAddPlaceHolders :: Functor f => f a -> f (PlaceHolders p, a) unsafeAddPlaceHolders =  fmap ((,) PlaceHolders)@@ -515,21 +506,139 @@   just         = Record.just   flattenMaybe = Record.flattenMaybe --- | Zipping except for identity element laws against placeholder parameter type.-instance ProductIsoEmpty PlaceHolders () where-  pureE   = unsafePlaceHolders-  peRight = unsafeCastPlaceHolders-  peLeft  = unsafeCastPlaceHolders --- | Compose seed of record type 'PlaceHolders'.-instance ProductIsoFunctor PlaceHolders where-  _ |$| PlaceHolders = PlaceHolders+-- | Unsafely make aggregation uni-operator from SQL keyword.+unsafeAggregateOp :: (AggregatedContext ac, SqlContext ac)+                  => SQL.Keyword -> Record Flat a -> Record ac b+unsafeAggregateOp op = unsafeUniOp ((op SQL.<++>) . SQL.paren) --- | Compose record type 'PlaceHolders' using applicative style.-instance ProductIsoApplicative PlaceHolders where-  pureP _   = unsafeCastPlaceHolders unitPH-  pf |*| pa = unsafeCastPlaceHolders (pf >< pa)+-- | Aggregation function COUNT.+count :: (Integral b, AggregatedContext ac, SqlContext ac)+      => Record Flat a -> Record ac b+count =  unsafeAggregateOp SQL.COUNT +-- | Aggregation function SUM.+sumMaybe :: (Num a, AggregatedContext ac, SqlContext ac)+         => Record Flat (Maybe a) -> Record ac (Maybe a)+sumMaybe  =  unsafeAggregateOp SQL.SUM++-- | Aggregation function SUM.+sum' :: (Num a, AggregatedContext ac, SqlContext ac)+     => Record Flat a -> Record ac (Maybe a)+sum'  =  sumMaybe . Record.just++-- | Aggregation function AVG.+avgMaybe :: (Num a, Fractional b, AggregatedContext ac, SqlContext ac)+         => Record Flat (Maybe a) -> Record ac (Maybe b)+avgMaybe   =  unsafeAggregateOp SQL.AVG++-- | Aggregation function AVG.+avg :: (Num a, Fractional b, AggregatedContext ac, SqlContext ac)+    => Record Flat a -> Record ac (Maybe b)+avg =  avgMaybe . Record.just++-- | Aggregation function MAX.+maxMaybe :: (Ord a, AggregatedContext ac, SqlContext ac)+         => Record Flat (Maybe a) -> Record ac (Maybe a)+maxMaybe  =  unsafeAggregateOp SQL.MAX++-- | Aggregation function MAX.+max' :: (Ord a, AggregatedContext ac, SqlContext ac)+     => Record Flat a -> Record ac (Maybe a)+max' =  maxMaybe . Record.just++-- | Aggregation function MIN.+minMaybe :: (Ord a, AggregatedContext ac, SqlContext ac)+         => Record Flat (Maybe a) -> Record ac (Maybe a)+minMaybe  =  unsafeAggregateOp SQL.MIN++-- | Aggregation function MIN.+min' :: (Ord a, AggregatedContext ac, SqlContext ac)+     => Record Flat a -> Record ac (Maybe a)+min' =  minMaybe . Record.just++-- | Aggregation function EVERY.+every :: (AggregatedContext ac, SqlContext ac)+      => Predicate Flat -> Record ac (Maybe Bool)+every =  unsafeAggregateOp SQL.EVERY++-- | Aggregation function ANY.+any' :: (AggregatedContext ac, SqlContext ac)+     => Predicate Flat -> Record ac (Maybe Bool)+any'  =  unsafeAggregateOp SQL.ANY++-- | Aggregation function SOME.+some' :: (AggregatedContext ac, SqlContext ac)+      => Predicate Flat -> Record ac (Maybe Bool)+some' =  unsafeAggregateOp SQL.SOME++-- | Get narrower record along with projection path.+(!) :: PersistableWidth a+    => Record c a -- ^ Source 'Record'+    -> Pi a b     -- ^ Record path+    -> Record c b -- ^ Narrower projected object+(!) = Record.pi++-- | Get narrower record along with projection path+--   'Maybe' phantom functor is 'map'-ed.+(?!) :: PersistableWidth a+     => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' type+     -> Pi a b             -- ^ Record path+     -> Record c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result+(?!) = Record.piMaybe++-- | Get narrower record along with projection path+--   and project into result record type.+--   Source record 'Maybe' phantom functor and projection path leaf 'Maybe' functor are 'join'-ed.+(?!?) :: PersistableWidth a+      => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type+      -> Pi a (Maybe b)     -- ^ Record path. 'Maybe' type leaf+      -> Record c (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result+(?!?) = Record.piMaybe'+++-- | Interface to compose phantom 'Maybe' nested type.+class ProjectableFlattenMaybe a b where+  flatten :: ProjectableMaybe p => p a -> p b++-- | Compose 'Maybe' type in record phantom type.+instance ProjectableFlattenMaybe (Maybe a) b+         => ProjectableFlattenMaybe (Maybe (Maybe a)) b where+  flatten = flatten . flattenMaybe++-- | Not 'Maybe' type is not processed.+instance ProjectableFlattenMaybe (Maybe a) (Maybe a) where+  flatten = id++-- | Get narrower record with flatten leaf phantom Maybe types along with projection path.+flattenPiMaybe :: (PersistableWidth a, ProjectableMaybe (Record cont), ProjectableFlattenMaybe (Maybe b) c)+               => Record cont (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type+               -> Pi a b                -- ^ Projection path+               -> Record cont c         -- ^ Narrower 'Record'. Flatten 'Maybe' phantom type+flattenPiMaybe p = flatten . Record.piMaybe p++-- | Get narrower record with flatten leaf phantom Maybe types along with projection path.+(!??) :: (PersistableWidth a, ProjectableMaybe (Record cont), ProjectableFlattenMaybe (Maybe b) c)+      => Record cont (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type+      -> Pi a b                -- ^ Projection path+      -> Record cont c         -- ^ Narrower flatten and projected object.+(!??) = flattenPiMaybe++-- | Same as '(?!)'. Use this operator like '(? #foo) mayX'.+(?) :: PersistableWidth a+    => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' type+    -> Pi a b             -- ^ Record path+    -> Record c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result+(?) = (?!)++-- | Same as '(?!?)'. Use this operator like '(?? #foo) mayX'.+(??) :: PersistableWidth a+     => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type+     -> Pi a (Maybe b)     -- ^ Record path. 'Maybe' type leaf+     -> Record c (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result+(??) = (?!?)++infixl 8 !, ?, ??, ?!, ?!?, !?? infixl 7 .*., ./., ?*?, ?/? infixl 6 .+., .-., ?+?, ?-? infixl 5 .||., ?||?
+ src/Database/Relational/Projectable/Instances.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.Relational.Projectable.Instances+-- Copyright   : 2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides instances between projected terms and SQL terms.+module Database.Relational.Projectable.Instances () where++import Data.Functor.ProductIsomorphic+  (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|),+   ProductIsoEmpty, pureE, peRight, peLeft, )++import Database.Relational.Internal.ContextType+  (Flat, Aggregated, OverWindow)+import qualified Database.Relational.Record as Record+import Database.Relational.Projectable.Unsafe+  (SqlContext (..), OperatorContext, AggregatedContext, PlaceHolders (..))++-- context++-- | Unsafely make 'Record' from SQL terms.+instance SqlContext Flat where+  unsafeProjectSqlTerms = Record.unsafeFromSqlTerms++-- | Unsafely make 'Record' from SQL terms.+instance SqlContext Aggregated where+  unsafeProjectSqlTerms = Record.unsafeFromSqlTerms++-- | Unsafely make 'Record' from SQL terms.+instance SqlContext OverWindow where+  unsafeProjectSqlTerms = Record.unsafeFromSqlTerms++-- | full SQL expression is availabe in Flat context+instance OperatorContext Flat+-- | full SQL expression is availabe in Aggregated context+instance OperatorContext Aggregated++-- | 'Aggregated' context is aggregated context+instance AggregatedContext Aggregated+-- | 'OverWindow' context is aggregated context+instance AggregatedContext OverWindow++-- placeholders++-- | Zipping except for identity element laws against placeholder parameter type.+instance ProductIsoEmpty PlaceHolders () where+  pureE     = PlaceHolders+  peRight _ = PlaceHolders+  peLeft  _ = PlaceHolders++-- | Compose seed of record type 'PlaceHolders'.+instance ProductIsoFunctor PlaceHolders where+  _ |$| PlaceHolders = PlaceHolders++-- | Compose record type 'PlaceHolders' using applicative style.+instance ProductIsoApplicative PlaceHolders where+  pureP _     = PlaceHolders+  _pf |*| _pa = PlaceHolders
+ src/Database/Relational/Projectable/Unsafe.hs view
@@ -0,0 +1,35 @@+-- |+-- Module      : Database.Relational.Projectable.Unsafe+-- Copyright   : 2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides unsafe interfaces between projected terms and SQL terms.+module Database.Relational.Projectable.Unsafe (+  SqlContext (..), OperatorContext, AggregatedContext,+  PlaceHolders (..)+  ) where++import Database.Relational.Internal.String (StringSQL)+import Database.Relational.SqlSyntax (Record)++-- | Interface to project SQL terms unsafely.+class SqlContext c where+  -- | Unsafely project from SQL expression terms.+  unsafeProjectSqlTerms :: [StringSQL]+                        -> Record c t++-- | Constraint to restrict context of full SQL expressions.+--   For example, the expression at the left of OVER clause+--   is not allowed using full SQL expression.+class SqlContext c => OperatorContext c++-- | Constraint to restrict context of aggregated SQL context.+class AggregatedContext ac+++-- | Placeholder parameter type which has real parameter type arguemnt 'p'.+data PlaceHolders p = PlaceHolders
− src/Database/Relational/ProjectableExtended.hs 
@@ -1,168 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}---- |--- Module      : Database.Relational.ProjectableExtended--- Copyright   : 2013-2017 Kei Hibino--- License     : BSD3------ Maintainer  : ex8k.hibino@gmail.com--- Stability   : experimental--- Portability : unknown------ This module defines operators on various projected records.-module Database.Relational.ProjectableExtended (-  -- * Projection for nested 'Maybe's-  ProjectableFlattenMaybe (flatten),--  flattenPiMaybe,--  -- * Get narrower records-  (!), (?!), (?!?), (!??),--  -- * Aggregate functions-  unsafeAggregateOp,-  count,-  sum', sumMaybe, avg, avgMaybe,-  max', maxMaybe, min', minMaybe,-  every, any', some',-  )  where--import Prelude hiding (pi)--import qualified Language.SQL.Keyword as SQL-import Database.Record (PersistableWidth)--import Database.Relational.Internal.ContextType (Flat, Aggregated, OverWindow)-import Database.Relational.SqlSyntax (Predicate, Record, )--import qualified Database.Relational.Record as Record-import Database.Relational.Projectable-  (unsafeUniOp, ProjectableMaybe (flattenMaybe), SqlContext)-import Database.Relational.Pi (Pi)---class AggregatedContext ac-instance AggregatedContext Aggregated-instance AggregatedContext OverWindow---- | Unsafely make aggregation uni-operator from SQL keyword.-unsafeAggregateOp :: (AggregatedContext ac, SqlContext ac)-                  => SQL.Keyword -> Record Flat a -> Record ac b-unsafeAggregateOp op = unsafeUniOp ((op SQL.<++>) . SQL.paren)---- | Aggregation function COUNT.-count :: (Integral b, AggregatedContext ac, SqlContext ac)-      => Record Flat a -> Record ac b-count =  unsafeAggregateOp SQL.COUNT---- | Aggregation function SUM.-sumMaybe :: (Num a, AggregatedContext ac, SqlContext ac)-         => Record Flat (Maybe a) -> Record ac (Maybe a)-sumMaybe  =  unsafeAggregateOp SQL.SUM---- | Aggregation function SUM.-sum' :: (Num a, AggregatedContext ac, SqlContext ac)-     => Record Flat a -> Record ac (Maybe a)-sum'  =  sumMaybe . Record.just---- | Aggregation function AVG.-avgMaybe :: (Num a, Fractional b, AggregatedContext ac, SqlContext ac)-         => Record Flat (Maybe a) -> Record ac (Maybe b)-avgMaybe   =  unsafeAggregateOp SQL.AVG---- | Aggregation function AVG.-avg :: (Num a, Fractional b, AggregatedContext ac, SqlContext ac)-    => Record Flat a -> Record ac (Maybe b)-avg =  avgMaybe . Record.just---- | Aggregation function MAX.-maxMaybe :: (Ord a, AggregatedContext ac, SqlContext ac)-         => Record Flat (Maybe a) -> Record ac (Maybe a)-maxMaybe  =  unsafeAggregateOp SQL.MAX---- | Aggregation function MAX.-max' :: (Ord a, AggregatedContext ac, SqlContext ac)-     => Record Flat a -> Record ac (Maybe a)-max' =  maxMaybe . Record.just---- | Aggregation function MIN.-minMaybe :: (Ord a, AggregatedContext ac, SqlContext ac)-         => Record Flat (Maybe a) -> Record ac (Maybe a)-minMaybe  =  unsafeAggregateOp SQL.MIN---- | Aggregation function MIN.-min' :: (Ord a, AggregatedContext ac, SqlContext ac)-     => Record Flat a -> Record ac (Maybe a)-min' =  minMaybe . Record.just---- | Aggregation function EVERY.-every :: (AggregatedContext ac, SqlContext ac)-      => Predicate Flat -> Record ac (Maybe Bool)-every =  unsafeAggregateOp SQL.EVERY---- | Aggregation function ANY.-any' :: (AggregatedContext ac, SqlContext ac)-     => Predicate Flat -> Record ac (Maybe Bool)-any'  =  unsafeAggregateOp SQL.ANY---- | Aggregation function SOME.-some' :: (AggregatedContext ac, SqlContext ac)-      => Predicate Flat -> Record ac (Maybe Bool)-some' =  unsafeAggregateOp SQL.SOME---- | Get narrower record along with projection path.-(!) :: PersistableWidth a-    => Record c a -- ^ Source 'Record'-    -> Pi a b     -- ^ Record path-    -> Record c b -- ^ Narrower projected object-(!) = Record.pi---- | Get narrower record along with projection path---   'Maybe' phantom functor is 'map'-ed.-(?!) :: PersistableWidth a-     => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' type-     -> Pi a b             -- ^ Record path-     -> Record c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result-(?!) = Record.piMaybe---- | Get narrower record along with projection path---   and project into result record type.---   Source record 'Maybe' phantom functor and projection path leaf 'Maybe' functor are 'join'-ed.-(?!?) :: PersistableWidth a-      => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type-      -> Pi a (Maybe b)     -- ^ Record path. 'Maybe' type leaf-      -> Record c (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result-(?!?) = Record.piMaybe'----- | Interface to compose phantom 'Maybe' nested type.-class ProjectableFlattenMaybe a b where-  flatten :: ProjectableMaybe p => p a -> p b---- | Compose 'Maybe' type in record phantom type.-instance ProjectableFlattenMaybe (Maybe a) b-         => ProjectableFlattenMaybe (Maybe (Maybe a)) b where-  flatten = flatten . flattenMaybe---- | Not 'Maybe' type is not processed.-instance ProjectableFlattenMaybe (Maybe a) (Maybe a) where-  flatten = id---- | Get narrower record with flatten leaf phantom Maybe types along with projection path.-flattenPiMaybe :: (PersistableWidth a, ProjectableMaybe (Record cont), ProjectableFlattenMaybe (Maybe b) c)-               => Record cont (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type-               -> Pi a b                -- ^ Projection path-               -> Record cont c         -- ^ Narrower 'Record'. Flatten 'Maybe' phantom type-flattenPiMaybe p = flatten . Record.piMaybe p---- | Get narrower record with flatten leaf phantom Maybe types along with projection path.-(!??) :: (PersistableWidth a, ProjectableMaybe (Record cont), ProjectableFlattenMaybe (Maybe b) c)-      => Record cont (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type-      -> Pi a b                -- ^ Projection path-      -> Record cont c         -- ^ Narrower flatten and projected object.-(!??) = flattenPiMaybe---infixl 8 !, ?!, ?!?, !??
+ src/Database/Relational/Sequence.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Database.Relational.Sequence+-- Copyright   : 2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides structures about sequence tables.+module Database.Relational.Sequence (+  Sequence (..), seqRelation,+  unsafeSpecifySequence,++  SequenceDerivable (..),++  Binding (..), fromRelation,++  Number, unsafeSpecifyNumber, extractNumber,+  ($$!), ($$),++  updateNumber,+  ) where++import Prelude hiding (seq)++import Database.Record (PersistableWidth)+import Database.Relational.Monad.Class (wheres)+import Database.Relational.Monad.BaseType (Relation)+import Database.Relational.Monad.Trans.Assigning ((<-#))+import Database.Relational.Table (TableDerivable, derivedTable, Table)+import Database.Relational.Pi (Pi)+import Database.Relational.Projectable ((.<=.), value, unitPlaceHolder, (!))+import Database.Relational.ProjectableClass (ShowConstantTermsSQL)+import Database.Relational.Relation (tableOf)+import qualified Database.Relational.Relation as Relation+import Database.Relational.Effect (updateTarget')+import Database.Relational.Type (Update, typedUpdate)+++-- | Basic record to express sequence table+data Sequence s i =+  Sequence+  { seqTable :: Table s+  , seqExtract :: s -> i+  , seqKey :: Pi s i+  }++-- | Unsafely specify sequence table.+unsafeSpecifySequence :: TableDerivable s => (s -> i) -> Pi s i -> Sequence s i+unsafeSpecifySequence = Sequence derivedTable++-- | Infer 'Relation' of sequence table+seqRelation :: TableDerivable s => Sequence s i -> Relation () s+seqRelation = Relation.table . seqTable++-- | 'Sequence' derivation rule+class TableDerivable s => SequenceDerivable s i | s -> i where+  derivedSequence :: Sequence s i++-- | Derivation rule for binding between 'Table' and 'Sequence'+class (TableDerivable r, SequenceDerivable s i)+      => Binding r s i | r -> s  where+  fromTable :: Table r -> Sequence s i+  fromTable = const derivedSequence++-- | Derive 'Sequence' from corresponding 'Relation'+fromRelation :: Binding r s i+             => Relation () r+             -> Sequence s i+fromRelation = fromTable . tableOf++-- | Sequence number type for record type 'r'+newtype Number r i = Number i deriving (Eq, Ord, Show)++-- | Unsafely specify sequence number.+unsafeSpecifyNumber :: Binding r s i => i -> Number r i+unsafeSpecifyNumber = Number++-- | Get untyped sequence number.+extractNumber :: Number r i -> i+extractNumber (Number i) = i++-- | Unsafely apply sequence number.+($$!) :: (i -> r)    -- ^ sequence number should be passed to proper field of record+      -> Number r i+      -> r+($$!) = (. extractNumber)++-- | Unsafely apply sequence number. Only safe to build corresponding record type.+($$) :: Binding r s i+     => (i -> r)   -- ^ sequence number should be passed to proper field of record+     -> Number r i+     -> r+($$) = ($$!)++{-+updateNumber :: PersistableWidth p => Sequence r p -> Update (p, p)+updateNumber seqt = typedUpdate (table seqt) . updateTarget' $ \ proj -> do+  (phv', ()) <- placeholder (\ph -> key seqt <-# ph)+  (phx', ()) <- placeholder (\ph -> wheres $ proj ! key seqt .<=. ph)+  return $ (,) |$| phv' |*| phx'+ -}++-- | Update statement for sequence table+updateNumber :: (PersistableWidth s, Integral i, ShowConstantTermsSQL i)+             => i            -- ^ sequence number to set. expect not SQL injectable.+             -> Sequence s i -- ^ sequence table+             -> Update ()+updateNumber i seqt = typedUpdate (seqTable seqt) . updateTarget' $ \ proj -> do+  let iv = value i+  seqKey seqt <-# iv+  wheres $ proj ! seqKey seqt .<=. iv -- fool proof+  return unitPlaceHolder
src/Database/Relational/TH.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE CPP #-}  -- | -- Module      : Database.Relational.TH@@ -36,7 +37,8 @@   defineScalarDegree,    -- * Column projections-  defineColumns, defineColumnsDefault,+  defineColumnsDefault, defineOverloadedColumnsDefault,+  defineColumns, defineOverloadedColumns,    defineTuplePi, @@ -58,6 +60,7 @@    -- * Reify   makeRelationalRecordDefault,+  makeRelationalRecordDefault',   reifyRelation,   ) where @@ -73,7 +76,8 @@    TypeQ, Type (AppT, ConT), varT, tupleT, appT, arrowT, classP) import Language.Haskell.TH.Compat.Reify (unVarI) import Language.Haskell.TH.Name.CamelCase-  (VarName, varName, ConName (ConName), conName, varNameWithPrefix, varCamelcaseName, toVarExp, toTypeCon)+  (VarName, varName, ConName (ConName), conName,+   varNameWithPrefix, varCamelcaseName, toVarExp, toTypeCon) import Language.Haskell.TH.Lib.Extra (simpleValD, maybeD, integralE)  import Database.Record.TH@@ -83,15 +87,16 @@  import Database.Relational   (Table, Pi, id', Relation, ShowConstantTermsSQL,-   NameConfig (..), SchemaNameMode (..), IdentifierQuotation (..),-   Config (normalizedTableName, schemaNameMode, nameConfig, identifierQuotation),+   NameConfig (..), SchemaNameMode (..), IdentifierQuotation (..), defaultConfig,+   Config (normalizedTableName, disableOverloadedProjection, disableSpecializedProjection,+           schemaNameMode, nameConfig, identifierQuotation),    relationalQuerySQL, Query, relationalQuery, KeyUpdate,    Insert, derivedInsert, InsertQuery, derivedInsertQuery,    HasConstraintKey(constraintKey), Primary, NotNull, primary, primaryUpdate) -import Database.Relational.BaseTH (defineTuplePi, defineRecordProjections)+import Database.Relational.InternalTH.Base (defineTuplePi, defineRecordProjections) import Database.Relational.Scalar (defineScalarDegree)-import Database.Relational.Constraint (Key, unsafeDefineConstraintKey)+import Database.Relational.Constraint (unsafeDefineConstraintKey) import Database.Relational.Table (TableDerivable (..)) import qualified Database.Relational.Table as Table import Database.Relational.Relation (derivedRelation)@@ -99,6 +104,7 @@ import Database.Relational.Type (unsafeTypedQuery) import qualified Database.Relational.Pi.Unsafe as UnsafePi +import qualified Database.Relational.InternalTH.Overloaded as Overloaded  -- | Rule template to infer constraint key. defineHasConstraintKeyInstance :: TypeQ   -- ^ Constraint type@@ -150,52 +156,48 @@   defineHasNotNullKeyInstance . fst . recordTemplate (recordConfig $ nameConfig config) scm  --- | Column projection path 'Pi' template.-columnTemplate' :: TypeQ   -- ^ Record type-                -> VarName -- ^ Column declaration variable name-                -> ExpQ    -- ^ Column index expression in record (begin with 0)-                -> TypeQ   -- ^ Column type-                -> Q [Dec] -- ^ Column projection path declaration-columnTemplate' recType var' iExp colType = do-  let var = varName var'-  simpleValD var [t| Pi $recType $colType |]-    [| UnsafePi.definePi $(iExp) |]---- | Column projection path 'Pi' and constraint key template.-columnTemplate :: Maybe (TypeQ, VarName) -- ^ May Constraint type and constraint object name-               -> TypeQ                  -- ^ Record type-               -> VarName                -- ^ Column declaration variable name-               -> ExpQ                   -- ^ Column index expression in record (begin with 0)-               -> TypeQ                  -- ^ Column type-               -> Q [Dec]                -- ^ Column projection path declaration-columnTemplate mayConstraint recType var' iExp colType = do-  col <- columnTemplate' recType var' iExp colType-  cr  <- maybe-    (return [])-    ( \(constraint, cname') -> do-         simpleValD (varName cname') [t| Key $constraint $recType $colType |]-           [| unsafeDefineConstraintKey $(iExp) |] )-    mayConstraint-  return $ col ++ cr+projectionTemplate :: ConName   -- ^ Record type name+                   -> VarName   -- ^ Column declaration variable name+                   -> Int       -- ^ Column leftest index+                   -> TypeQ     -- ^ Column type+                   -> Q [Dec]   -- ^ Column projection path declaration+projectionTemplate recName var ix colType = do+  let offsetsExp = toVarExp . columnOffsetsVarNameDefault $ conName recName+  simpleValD (varName var)+    [t| Pi $(toTypeCon recName) $colType |]+    [| UnsafePi.definePi $ $offsetsExp ! $(integralE ix) |] --- | Column projection path 'Pi' templates.-defineColumns :: ConName                                      -- ^ Record type name-              -> [((VarName, TypeQ), Maybe (TypeQ, VarName))] -- ^ Column info list-              -> Q [Dec]                                      -- ^ Column projection path declarations+-- | Projection path 'Pi' templates.+defineColumns :: ConName           -- ^ Record type name+              -> [(VarName, TypeQ)] -- ^ Column info list+              -> Q [Dec]           -- ^ Column projection path declarations defineColumns recTypeName cols = do-  let defC ((cn, ct), mayCon) ix = columnTemplate mayCon (toTypeCon recTypeName) cn-                                   [| $(toVarExp . columnOffsetsVarNameDefault $ conName recTypeName) ! $(integralE ix) |] ct+  let defC (name, typ) ix = projectionTemplate recTypeName name ix typ   fmap concat . sequence $ zipWith defC cols [0 :: Int ..] --- | Make column projection path and constraint key templates using default naming rule.-defineColumnsDefault :: ConName                          -- ^ Record type name-                     -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column info list-                     -> Q [Dec]                          -- ^ Column projection path declarations+-- | Overloaded projection path 'Pi' templates.+defineOverloadedColumns :: ConName           -- ^ Record type name+                        -> [(String, TypeQ)] -- ^ Column info list+                        -> Q [Dec]           -- ^ Column projection path declarations+defineOverloadedColumns recTypeName cols = do+  let defC (name, typ) ix =+        Overloaded.monomorphicProjection recTypeName name ix typ+  fmap concat . sequence $ zipWith defC cols [0 :: Int ..]++-- | Make projection path templates using default naming rule.+defineColumnsDefault :: ConName           -- ^ Record type name+                     -> [(String, TypeQ)] -- ^ Column info list+                     -> Q [Dec]           -- ^ Column projection path declarations defineColumnsDefault recTypeName cols =-  defineColumns recTypeName [((varN n, ct), fmap (withCName n) mayC) | ((n, ct), mayC) <- cols]-  where varN      name   = varCamelcaseName (name ++ "'")-        withCName name t = (t, varCamelcaseName ("constraint_key_" ++ name))+  defineColumns     recTypeName [ (varCamelcaseName $ name ++ "'",             typ) | (name, typ) <- cols ] +-- | Make overloaded projection path templates using default naming rule.+defineOverloadedColumnsDefault :: ConName           -- ^ Record type name+                               -> [(String, TypeQ)] -- ^ Column info list+                               -> Q [Dec]           -- ^ Column projection path declarations+defineOverloadedColumnsDefault recTypeName cols =+  defineOverloadedColumns recTypeName [ (nameBase . varName $ varCamelcaseName name, typ) | (name, typ) <- cols ]+ -- | Rule template to infer table derivations. defineTableDerivableInstance :: TypeQ -> String -> [String] -> Q [Dec] defineTableDerivableInstance recordType' table columns =@@ -289,11 +291,11 @@     |]  -- | Make templates about table and column metadatas using specified naming rule.-defineTableTypesWithConfig :: Config                           -- ^ Configuration to generate query with-                           -> String                           -- ^ Schema name-                           -> String                           -- ^ Table name-                           -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column names and types and constraint type-                           -> Q [Dec]                          -- ^ Result declarations+defineTableTypesWithConfig :: Config            -- ^ Configuration to generate query with+                           -> String            -- ^ Schema name+                           -> String            -- ^ Table name+                           -> [(String, TypeQ)] -- ^ Column names and types and constraint type+                           -> Q [Dec]           -- ^ Result declarations defineTableTypesWithConfig config schema table columns = do   let nmconfig = nameConfig config       recConfig = recordConfig nmconfig@@ -304,9 +306,15 @@              (table `varNameWithPrefix` "insertQuery")              (fst $ recordTemplate recConfig schema table)              (tableSQL (normalizedTableName config) (schemaNameMode config) (identifierQuotation config) schema table)-             (map ((quote (identifierQuotation config)) . fst . fst) columns)-  colsDs <- defineColumnsDefault (recordTypeName recConfig schema table) columns-  return $ tableDs ++ colsDs+             (map ((quote (identifierQuotation config)) . fst) columns)+  let typeName = recordTypeName recConfig schema table+  colsDs  <- if disableSpecializedProjection config+             then [d| |]+             else defineColumnsDefault     typeName columns+  pcolsDs <- if disableOverloadedProjection config+             then [d| |]+             else defineOverloadedColumnsDefault typeName columns+  return $ tableDs ++ colsDs ++ pcolsDs  -- | Make templates about table, column and haskell record using specified naming rule. defineTableTypesAndRecord :: Config            -- ^ Configuration to generate query with@@ -320,7 +328,7 @@   recD    <- defineRecordTypeWithConfig recConfig schema table columns derives   rconD   <- defineProductConstructorInstanceWithConfig config schema table [t | (_, t) <- columns]   ctD     <- [d| instance ShowConstantTermsSQL $(fst $ recordTemplate recConfig schema table) |]-  tableDs <- defineTableTypesWithConfig config schema table [(c, Nothing) | c <- columns ]+  tableDs <- defineTableTypesWithConfig config schema table columns   return $ recD ++ rconD ++ ctD ++ tableDs  -- | Template of derived primary 'Query'.@@ -450,9 +458,10 @@  -- | Generate all templates against defined record like type constructor --   other than depending on sql-value type.-makeRelationalRecordDefault :: Name    -- ^ Type constructor name-                            -> Q [Dec] -- ^ Result declaration-makeRelationalRecordDefault recTypeName = do+makeRelationalRecordDefault' :: Config+                             -> Name    -- ^ Type constructor name+                             -> Q [Dec] -- ^ Result declaration+makeRelationalRecordDefault' config recTypeName = do   let recTypeConName = ConName recTypeName   (((tyCon, vars), _dataCon), (mayNs, cts)) <- reifyRecordType recTypeName   pw <- Record.definePersistableWidthInstance tyCon vars@@ -461,15 +470,34 @@     Just ns   ->  case vars of       []      ->  do {- monomorphic case -}         off <- Record.defineColumnOffsets recTypeConName-        cs  <- defineColumnsDefault recTypeConName-               [ ((nameBase n, ct), Nothing) | n  <- ns  | ct <- cts ]-        return $ off ++ cs-      _:_     ->     {- polymorphic case -}-        defineRecordProjections tyCon vars-          [varName $ varCamelcaseName (nameBase n ++ "'") | n <- ns]-          cts+        let cnames =  [ (nameBase n, ct) | n  <- ns  | ct <- cts ]+        cs  <- if disableSpecializedProjection config+               then [d| |]+               else defineColumnsDefault     recTypeConName cnames+        pcs <- if disableOverloadedProjection config+               then [d| |]+               else defineOverloadedColumnsDefault recTypeConName cnames+        return $ off ++ cs ++ pcs+      _:_     ->  do {- polymorphic case -}+        cols <- if disableSpecializedProjection config+                then [d| |]+                else defineRecordProjections tyCon vars+                     [varName $ varCamelcaseName (nameBase n ++ "'") | n <- ns]+                     cts+        ovls <- if disableOverloadedProjection config+                then [d| |]+                else Overloaded.polymorphicProjections tyCon vars+                     [nameBase n | n <- ns]+                     cts+        return $ cols ++ ovls    pc <- defineProductConstructor recTypeName   let scPred v = classP ''ShowConstantTermsSQL [varT v]   ct <- instanceD (mapM scPred vars) (appT [t| ShowConstantTermsSQL |] tyCon) []   return $ concat [pw, cols, pc, [ct]]++-- | Generate all templates against defined record like type constructor+--   other than depending on sql-value type.+makeRelationalRecordDefault ::  Name   -- ^ Type constructor name+                            -> Q [Dec] -- ^ Result declaration+makeRelationalRecordDefault = makeRelationalRecordDefault' defaultConfig
src/Database/Relational/Table.hs view
@@ -10,7 +10,9 @@ -- This module defines table type which has table metadatas. module Database.Relational.Table (   -- * Phantom typed table type-  Table, unType, name, shortName, width, columns, index, table, toMaybe, recordWidth,+  Table, untype, name, shortName, width, columns, index, table, toMaybe, recordWidth,+  unType,+   toSubQuery,    -- * Table existence inference@@ -32,12 +34,17 @@ newtype Table r = Table Untyped  -- | Untype table.+untype :: Table t -> Untyped+untype (Table u) = u++{-# DEPRECATED unType "Use untype instead of this." #-}+-- | Deprecated. use 'untype'. unType :: Table t -> Untyped-unType (Table u) = u+unType = untype  -- | Name string of table in SQL name :: Table r -> String-name   = name' . unType+name   = name' . untype  -- | Not qualified name string of table in SQL shortName :: Table r -> String@@ -45,17 +52,17 @@  -- | Width of table width :: Table r -> Int-width  = width' . unType+width  = width' . untype  -- | Column name strings in SQL columns :: Table r -> [StringSQL]-columns =  columns' . unType+columns =  columns' . untype  -- | Column name string in SQL specified by index index :: Table r       -> Int       -- ^ Column index       -> StringSQL -- ^ Column name String in SQL-index =  (!) . unType+index =  (!) . untype  -- | Cast phantom type into 'Maybe' type. toMaybe :: Table r -> Table (Maybe r)@@ -70,7 +77,7 @@ -- | 'SubQuery' from 'Table'. toSubQuery :: Table r  -- ^ Typed 'Table' metadata            -> SubQuery -- ^ Result 'SubQuery'-toSubQuery = Syntax.Table . unType+toSubQuery = Syntax.Table . untype  -- | Inference rule of 'Table' existence. class PersistableWidth r => TableDerivable r where
src/Database/Relational/TupleInstances.hs view
@@ -18,10 +18,21 @@  import Control.Applicative ((<$>)) -import Database.Relational.BaseTH+import Database.Record (PersistableWidth)++import Database.Relational.Pi (Pi)+import Database.Relational.InternalTH.Base   (defineTuplePi, defineTupleShowConstantInstance,)   $(concat <$> mapM defineTuplePi [2..7]) $(concat <$> mapM defineTupleShowConstantInstance [2..7]) -- Generic instances of tuple types are generated from 2 to 7 in GHC.Generics.++-- | Projection path for fst of tuple.+fst' :: (PersistableWidth a, PersistableWidth b) => Pi (a, b) a+fst' = tuplePi2_0'++-- | Projection path for snd of tuple.+snd' :: (PersistableWidth a, PersistableWidth b) => Pi (a, b) b+snd' = tuplePi2_1'
test/Model.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}  module Model where
test/sqlsEq.hs view
@@ -415,15 +415,6 @@    return $ fromMaybe (value 1) (a ?! intA0') >< b -maybeY :: Relation () (SetA, SetB)-maybeY =  relation $ do-  a <- queryMaybe setA-  b <- query setB--  wheres $ a ?! strA2' .=. b ! mayStrB1'--  return $ fromMaybe (SetA |$| value 1 |*| value "foo" |*| value "var") a >< b- notX :: Relation () (Maybe Bool) notX = relation $   return $ not' valueFalse@@ -447,12 +438,6 @@   , eqProp "fromMaybe" maybeX     "SELECT ALL CASE WHEN (T0.int_a0 IS NULL) THEN 1 ELSE T0.int_a0 END AS f0, \     \           T1.int_b0 AS f1, T1.may_str_b1 AS f2, T1.str_b2 AS f3 \-    \  FROM TEST.set_a T0 RIGHT JOIN TEST.set_b T1 ON (0=0) WHERE (T0.str_a2 = T1.may_str_b1)"-  , eqProp "fromMaybe record" maybeY-    "SELECT ALL CASE WHEN (T0.int_a0 IS NULL) THEN 1 ELSE T0.int_a0 END AS f0, \-    \           CASE WHEN (T0.int_a0 IS NULL) THEN 'foo' ELSE T0.str_a1 END AS f1, \-    \           CASE WHEN (T0.int_a0 IS NULL) THEN 'var' ELSE T0.str_a2 END AS f2, \-    \           T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \     \  FROM TEST.set_a T0 RIGHT JOIN TEST.set_b T1 ON (0=0) WHERE (T0.str_a2 = T1.may_str_b1)"   , eqProp "not" notX     "SELECT ALL (NOT (0=1)) AS f0"