Merge pull request #146 from morphismtech/dev-fun

User defined function support

squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs

@@ -19,6 +19,7 @@ Squeal data definition language.
   , GADTs
   , LambdaCase
   , MultiParamTypeClasses
+  , OverloadedLabels
   , OverloadedStrings
   , RankNTypes
   , ScopedTypeVariables
@@ -48,6 +49,13 @@ module Squeal.PostgreSQL.Definition
   , createDomain
   , createTypeRange
   , createIndex
+  , createFunction
+  , createOrReplaceFunction
+  , createSetFunction
+  , createOrReplaceSetFunction
+  , createBinaryOp
+  , createLeftOp
+  , createRightOp
   , TableConstraintExpression (..)
   , check
   , unique
@@ -56,12 +64,17 @@ module Squeal.PostgreSQL.Definition
   , ForeignKeyed
   , OnDeleteClause (..)
   , OnUpdateClause (..)
+  , FunctionDefinition(..)
+  , languageSqlExpr
+  , languageSqlQuery
     -- ** Drop
   , dropSchema
   , dropTable
   , dropView
   , dropType
   , dropIndex
+  , dropFunction
+  , dropOperator
     -- ** Alter
   , alterTable
   , alterTableRename
@@ -576,6 +589,7 @@ DROP statements
 dropSchema
   :: Has sch schemas schema
   => Alias sch
+  -- ^ user defined schema
   -> Definition schemas (Drop sch schemas)
 dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
 
@@ -1124,13 +1138,169 @@ instance RenderSQL IndexMethod where
     Gin -> "gin"
     Brin -> "brin"
 
+createFunction
+  :: ( Has sch schemas schema
+     , KnownSymbol fun
+     , SOP.SListI args )
+  => QualifiedAlias sch fun
+  -> NP (TypeExpression schemas) args
+  -> TypeExpression schemas ret
+  -> FunctionDefinition schemas args ('Returns ret)
+  -> Definition schemas (Alter sch (Create fun ('Function args ('Returns ret)) schema) schemas)
+createFunction fun args ret fundef = UnsafeDefinition $
+  "CREATE" <+> "FUNCTION" <+> renderSQL fun
+    <+> parenthesized (renderCommaSeparated renderSQL args)
+    <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
+
+createOrReplaceFunction
+  :: ( Has sch schemas schema
+     , Has fun schema ('Function args0 ret0)
+     , SOP.SListI args )
+  => QualifiedAlias sch fun
+  -> NP (TypeExpression schemas) args
+  -> TypeExpression schemas ret
+  -> FunctionDefinition schemas args ('Returns ret)
+  -> Definition schemas (Alter sch (Alter fun ('Function args ('Returns ret)) schema) schemas)
+createOrReplaceFunction fun args ret fundef = UnsafeDefinition $
+  "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
+    <+> parenthesized (renderCommaSeparated renderSQL args)
+    <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
+
+languageSqlExpr
+  :: Expression '[] '[] 'Ungrouped schemas args '[] ret
+  -> FunctionDefinition schemas args ('Returns ret)
+languageSqlExpr expr = UnsafeFunctionDefinition $
+  "language sql as"
+    <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"
+
+languageSqlQuery
+  :: Query '[] '[] schemas args rets
+  -> FunctionDefinition schemas args ('ReturnsTable rets)
+languageSqlQuery qry = UnsafeFunctionDefinition $
+  "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"
+
+createSetFunction
+  :: ( Has sch schemas schema
+     , KnownSymbol fun
+     , SOP.SListI args
+     , SOP.SListI rets )
+  => QualifiedAlias sch fun
+  -> NP (TypeExpression schemas) args
+  -> NP (Aliased (TypeExpression schemas)) rets
+  -> FunctionDefinition schemas args ('ReturnsTable rets)
+  -> Definition schemas (Alter sch (Create fun ('Function args ('ReturnsTable rets)) schema) schemas)
+createSetFunction fun args rets fundef = UnsafeDefinition $
+  "CREATE" <+> "FUNCTION" <+> renderSQL fun
+    <+> parenthesized (renderCommaSeparated renderSQL args)
+    <+> "RETURNS" <+> "TABLE"
+    <+> parenthesized (renderCommaSeparated renderRet rets)
+    <+> renderSQL fundef <> ";"
+  where
+    renderRet :: Aliased (TypeExpression s) r -> ByteString
+    renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
+
+createOrReplaceSetFunction
+  :: ( Has sch schemas schema
+     , Has fun schema ('Function args0 ret0)
+     , SOP.SListI args
+     , SOP.SListI rets )
+  => QualifiedAlias sch fun
+  -> NP (TypeExpression schemas) args
+  -> NP (Aliased (TypeExpression schemas)) rets
+  -> FunctionDefinition schemas args ('ReturnsTable rets)
+  -> Definition schemas (Alter sch (Alter fun ('Function args ('ReturnsTable rets)) schema) schemas)
+createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $
+  "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
+    <+> parenthesized (renderCommaSeparated renderSQL args)
+    <+> "RETURNS" <+> "TABLE"
+    <+> parenthesized (renderCommaSeparated renderRet rets)
+    <+> renderSQL fundef <> ";"
+  where
+    renderRet :: Aliased (TypeExpression s) r -> ByteString
+    renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
+
+createBinaryOp
+  :: forall op fun sch schemas schema x y z.
+     ( Has sch schemas schema
+     , Has fun schema ('Function '[x,y] ('Returns z))
+     , KnownSymbol op )
+  => Alias fun
+  -> TypeExpression schemas x
+  -> TypeExpression schemas y
+  -> Definition schemas
+      (Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)
+createBinaryOp fun x y = UnsafeDefinition $
+  "CREATE" <+> "OPERATOR" <+> renderSymbol @op
+    <+> parenthesized (commaSeparated opdef)
+    where
+      opdef =
+        [ "FUNCTION" <+> "=" <+> renderSQL fun
+        , "LEFTARG" <+> "=" <+> renderSQL x
+        , "RIGHTARG" <+> "=" <+> renderSQL y ]
+
+createLeftOp
+  :: forall op fun sch schemas schema x y.
+     ( Has sch schemas schema
+     , Has fun schema ('Function '[x] ('Returns y))
+     , KnownSymbol op )
+  => Alias fun
+  -> TypeExpression schemas x
+  -> Definition schemas
+      (Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)
+createLeftOp fun x = UnsafeDefinition $
+  "CREATE" <+> "OPERATOR" <+> renderSymbol @op
+    <+> parenthesized (commaSeparated opdef)
+    where
+      opdef =
+        [ "FUNCTION" <+> "=" <+> renderSQL fun
+        , "RIGHTARG" <+> "=" <+> renderSQL x ]
+
+createRightOp
+  :: forall op fun sch schemas schema x y.
+     ( Has sch schemas schema
+     , Has fun schema ('Function '[x] ('Returns y))
+     , KnownSymbol op )
+  => Alias fun
+  -> TypeExpression schemas x
+  -> Definition schemas
+      (Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)
+createRightOp fun x = UnsafeDefinition $
+  "CREATE" <+> "OPERATOR" <+> renderSymbol @op
+    <+> parenthesized (commaSeparated opdef)
+    where
+      opdef =
+        [ "FUNCTION" <+> "=" <+> renderSQL fun
+        , "LEFTARG" <+> "=" <+> renderSQL x ]
+
+dropFunction
+  :: (Has sch schemas schema, Has fun schema ('Function args ret))
+  => QualifiedAlias sch fun
+  -- ^ name of the user defined function
+  -> Definition schemas (Alter sch (Drop fun schema) schemas)
+dropFunction fun = UnsafeDefinition $
+  "DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"
+
+dropOperator
+  :: (Has sch schemas schema, Has op schema ('Operator oper))
+  => QualifiedAlias sch op
+  -- ^ name of the user defined operator
+  -> Definition schemas (Alter sch (Drop op schema) schemas)
+dropOperator op = UnsafeDefinition $
+  "DROP" <+> "OPERATOR" <+> renderSQL op <> ";"
+
+newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition
+  { renderFunctionDefinition :: ByteString }
+  deriving (Eq,Show,GHC.Generic,NFData)
+instance RenderSQL (FunctionDefinition schemas args ret) where
+  renderSQL = renderFunctionDefinition
+
 -- |
 -- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index]) (Public '[]))
 -- DROP INDEX "ix";
 dropIndex
   :: (Has sch schemas schema, Has ix schema 'Index)
   => QualifiedAlias sch ix
-  -- ^ name of the user defined type
+  -- ^ name of the user defined index
   -> Definition schemas (Alter sch (Drop ix schema) schemas)
 dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"
 

squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs

@@ -35,15 +35,23 @@ module Squeal.PostgreSQL.Expression
     Expression (..)
   , Expr
   , (:-->)
+  , FunctionDB
   , unsafeFunction
-  , unsafeUnaryOpL
-  , unsafeUnaryOpR
+  , function
+  , unsafeLeftOp
+  , leftOp
+  , unsafeRightOp
+  , rightOp
   , Operator
+  , OperatorDB
   , unsafeBinaryOp
+  , binaryOp
   , FunctionVar
   , unsafeFunctionVar
   , FunctionN
+  , FunctionNDB
   , unsafeFunctionN
+  , functionN
   , PGSubset (..)
   , PGIntersect (..)
     -- * Re-export
@@ -137,6 +145,15 @@ type Operator x1 x2 y
   -> Expression outer commons grp schemas params from y
      -- ^ output
 
+type OperatorDB schemas x1 x2 y
+  =  forall outer commons grp params from
+  .  Expression outer commons grp schemas params from x1
+     -- ^ left input
+  -> Expression outer commons grp schemas params from x2
+     -- ^ right input
+  -> Expression outer commons grp schemas params from y
+     -- ^ output
+
 -- | A @RankNType@ for functions with a single argument.
 -- These could be either function calls or unary operators.
 -- This is a subtype of the usual Haskell function type `Prelude.->`,
@@ -149,6 +166,13 @@ type (:-->) x y
   -> Expression outer commons grp schemas params from y
      -- ^ output
 
+type FunctionDB schemas x y
+  =  forall outer commons grp params from
+  .  Expression outer commons grp schemas params from x
+     -- ^ input
+  -> Expression outer commons grp schemas params from y
+     -- ^ output
+
 {- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.
 Use the `*:` operator to end your argument lists, like so.
 
@@ -162,6 +186,13 @@ type FunctionN xs y
   -> Expression outer commons grp schemas params from y
      -- ^ output
 
+type FunctionNDB schemas xs y
+  =  forall outer commons grp params from
+  .  NP (Expression outer commons grp schemas params from) xs
+     -- ^ inputs
+  -> Expression outer commons grp schemas params from y
+     -- ^ output
+
 {- | A @RankNType@ for functions with a variable-length list of
 homogeneous arguments and at least 1 more argument.
 -}
@@ -287,15 +318,36 @@ unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2
 unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
   renderSQL x <+> op <+> renderSQL y
 
--- | >>> printSQL $ unsafeUnaryOpL "NOT" true
--- (NOT TRUE)
-unsafeUnaryOpL :: ByteString -> x :--> y
-unsafeUnaryOpL op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
+binaryOp
+  :: forall op sch schemas schema x y z.
+    ( Has sch schemas schema
+    , Has op schema ('Operator ('BinaryOp x y z)) )
+  => OperatorDB schemas x y z
+binaryOp = unsafeBinaryOp $ renderSymbol @op
 
--- | >>> printSQL $ true & unsafeUnaryOpR "IS NOT TRUE"
+-- | >>> printSQL $ unsafeLeftOp "NOT" true
+-- (NOT TRUE)
+unsafeLeftOp :: ByteString -> x :--> y
+unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
+
+leftOp
+  :: forall op sch schemas schema x y.
+    ( Has sch schemas schema
+    , Has op schema ('Operator ('LeftOp x y)) )
+  => FunctionDB schemas x y
+leftOp = unsafeLeftOp $ renderSymbol @op
+
+-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"
 -- (TRUE IS NOT TRUE)
-unsafeUnaryOpR :: ByteString -> x :--> y
-unsafeUnaryOpR op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
+unsafeRightOp :: ByteString -> x :--> y
+unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
+
+rightOp
+  :: forall op sch schemas schema x y.
+    ( Has sch schemas schema
+    , Has op schema ('Operator ('RightOp x y)) )
+  => FunctionDB schemas x y
+rightOp = unsafeRightOp $ renderSymbol @op
 
 -- | >>> printSQL $ unsafeFunction "f" true
 -- f(TRUE)
@@ -303,12 +355,26 @@ unsafeFunction :: ByteString -> x :--> y
 unsafeFunction fun x = UnsafeExpression $
   fun <> parenthesized (renderSQL x)
 
+function
+  :: (Has sch schemas schema, Has fun schema ('Function '[x] ('Returns y)))
+  => QualifiedAlias sch fun
+  -> FunctionDB schemas x y
+function = unsafeFunction . renderSQL
+
 -- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
 -- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
 unsafeFunctionN :: SListI xs => ByteString -> FunctionN xs y
 unsafeFunctionN fun xs = UnsafeExpression $
   fun <> parenthesized (renderCommaSeparated renderSQL xs)
 
+functionN
+  :: ( Has sch schemas schema
+     , Has fun schema ('Function xs ('Returns y))
+     , SListI xs )
+  => QualifiedAlias sch fun
+  -> FunctionNDB schemas xs y
+functionN = unsafeFunctionN . renderSQL
+
 instance ty `In` PGNum
   => Num (Expression outer commons grp schemas params from (null ty)) where
     (+) = unsafeBinaryOp "+"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs

@@ -163,7 +163,7 @@ isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"
 (TRUE IS TRUE)
 -}
 isTrue :: null0 'PGbool :--> null1 'PGbool
-isTrue = unsafeUnaryOpR "IS TRUE"
+isTrue = unsafeRightOp "IS TRUE"
 
 {- | is false or unknown
 
@@ -171,7 +171,7 @@ isTrue = unsafeUnaryOpR "IS TRUE"
 (TRUE IS NOT TRUE)
 -}
 isNotTrue :: null0 'PGbool :--> null1 'PGbool
-isNotTrue = unsafeUnaryOpR "IS NOT TRUE"
+isNotTrue = unsafeRightOp "IS NOT TRUE"
 
 {- | is false
 
@@ -179,7 +179,7 @@ isNotTrue = unsafeUnaryOpR "IS NOT TRUE"
 (TRUE IS FALSE)
 -}
 isFalse :: null0 'PGbool :--> null1 'PGbool
-isFalse = unsafeUnaryOpR "IS FALSE"
+isFalse = unsafeRightOp "IS FALSE"
 
 {- | is true or unknown
 
@@ -187,7 +187,7 @@ isFalse = unsafeUnaryOpR "IS FALSE"
 (TRUE IS NOT FALSE)
 -}
 isNotFalse :: null0 'PGbool :--> null1 'PGbool
-isNotFalse = unsafeUnaryOpR "IS NOT FALSE"
+isNotFalse = unsafeRightOp "IS NOT FALSE"
 
 {- | is unknown
 
@@ -195,7 +195,7 @@ isNotFalse = unsafeUnaryOpR "IS NOT FALSE"
 (TRUE IS UNKNOWN)
 -}
 isUnknown :: null0 'PGbool :--> null1 'PGbool
-isUnknown = unsafeUnaryOpR "IS UNKNOWN"
+isUnknown = unsafeRightOp "IS UNKNOWN"
 
 {- | is true or false
 
@@ -203,4 +203,4 @@ isUnknown = unsafeUnaryOpR "IS UNKNOWN"
 (TRUE IS NOT UNKNOWN)
 -}
 isNotUnknown :: null0 'PGbool :--> null1 'PGbool
-isNotUnknown = unsafeUnaryOpR "IS NOT UNKNOWN"
+isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs

@@ -48,7 +48,7 @@ false = UnsafeExpression "FALSE"
 -- | >>> printSQL $ not_ true
 -- (NOT TRUE)
 not_ :: null 'PGbool :--> null 'PGbool
-not_ = unsafeUnaryOpL "NOT"
+not_ = unsafeLeftOp "NOT"
 
 -- | >>> printSQL $ true .&& false
 -- (TRUE AND FALSE)

squeal-postgresql/src/Squeal/PostgreSQL/Expression/SetOf.hs

@@ -26,8 +26,10 @@ module Squeal.PostgreSQL.Expression.SetOf
   , generateSeriesTimestamp
   , SetOfFunction
   , unsafeSetOfFunction
+  , setOfFunction
   , SetOfFunctionN
   , unsafeSetOfFunctionN
+  , setOfFunctionN
   ) where
 
 import GHC.TypeLits
@@ -58,6 +60,15 @@ unsafeSetOfFunction
 unsafeSetOfFunction x = UnsafeFromClause $
   renderSymbol @fun <> parenthesized (renderSQL x)
 
+setOfFunction
+  :: ( Has sch schemas schema
+     , Has fun schema ('Function '[ty] ('ReturnsTable setof)) )
+  => Alias fun
+  -> ( forall outer commons params
+        .  Expression outer commons 'Ungrouped schemas params '[] ty
+        -> FromClause outer commons schemas params '[fun ::: setof] )
+setOfFunction _ = unsafeSetOfFunction
+
 {- |
 A @RankNType@ for set returning functions with multiple argument.
 -}
@@ -75,6 +86,16 @@ unsafeSetOfFunctionN
 unsafeSetOfFunctionN xs = UnsafeFromClause $
   renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)
 
+setOfFunctionN
+  :: ( Has sch schemas schema
+     , Has fun schema ('Function tys ('ReturnsTable setof))
+     , SOP.SListI tys )
+  => Alias fun
+  -> ( forall outer commons params
+        .  NP (Expression outer commons 'Ungrouped schemas params '[]) tys
+        -> FromClause outer commons schemas params '[fun ::: setof] )
+setOfFunctionN _ = unsafeSetOfFunctionN
+
 {- | @generateSeries (start *: stop)@
 
 Generate a series of values, from @start@ to @stop@ with a step size of one

squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs

@@ -56,7 +56,7 @@ import Squeal.PostgreSQL.Schema
 
 -- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`
 (.!) :: null 'PGtsquery :--> null 'PGtsquery
-(.!) = unsafeUnaryOpL "!!"
+(.!) = unsafeLeftOp "!!"
 
 -- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by
 -- `Squeal.PostgreSQL.Expression.Type.tsquery`

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs

@@ -44,6 +44,8 @@ module Squeal.PostgreSQL.Schema
   , ColumnsType
   , TableType
   , SchemumType (..)
+  , OperatorType (..)
+  , ReturnsType (..)
   , SchemaType
   , SchemasType
   , Public
@@ -367,8 +369,19 @@ data SchemumType
   | View RowType
   | Typedef PGType
   | Index
+  | Function [NullityType] ReturnsType
+  | Operator OperatorType
   | UnsafeSchemum Symbol
 
+data ReturnsType
+  = Returns NullityType
+  | ReturnsTable RowType
+
+data OperatorType
+  = BinaryOp NullityType NullityType NullityType
+  | LeftOp NullityType NullityType
+  | RightOp NullityType NullityType
+
 {- | The schema of a database consists of a list of aliased,
 user-defined `SchemumType`s.