{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Ribbit (
(:>)(..),
Table(..),
Field,
Select,
From,
X,
As,
Where,
And,
Or,
Equals,
type (?),
ArgsType,
ResultType,
Render(..)
) where
import Data.Proxy (Proxy(Proxy))
import Data.String (IsString, fromString)
import Data.Text (Text)
import Data.Tuple.Only (Only)
import Data.Type.Bool (If, type (||))
import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage((:<>:),
(:$$:), ShowType), AppendSymbol, Symbol)
import qualified GHC.TypeLits as Lit
data Select fields
data From proj relation
infixl 6 `From`
data Where query conditions
infixl 6 `Where`
data Equals l r
infix 9 `Equals`
data And l r
infixr 8 `And`
data Or l r
infixr 7 `Or`
data X l r
infixr 7 `X`
data As relation name
infix 8 `As`
data (?)
data Field name typ
data a :> b = a :> b
deriving (Eq, Ord, Show)
infixr 5 :>
data Expr a
type family ProjectionType proj schema where
ProjectionType '[name] schema =
LookupType name schema schema
ProjectionType (name:more) schema =
LookupType name schema schema
:> ProjectionType more schema
type family LookupType name schema context where
LookupType name (Field name typ) _ = Only typ
LookupType name (Field name typ :> _) _ = Only typ
LookupType name (Field _ typ) context = NotInSchema name context
LookupType name (_ :> more) context = LookupType name more context
LookupType name a context = NotInSchema name context
class Table relation where
type DBSchema relation
type Name relation :: Symbol
instance (Table l, Table r, KnownSymbol lname, KnownSymbol rname) => Table (l `As` lname `X` r `As` rname) where
type DBSchema (l `As` lname `X` r `As` rname) =
Flatten (
AliasAs lname (DBSchema l)
:> AliasAs rname (DBSchema r)
)
type Name (l `As` lname `X` r `As` rname) =
Name l
`AppendSymbol` " as "
`AppendSymbol` lname
`AppendSymbol` ", "
`AppendSymbol` Name r
`AppendSymbol` " as "
`AppendSymbol` rname
type family AliasAs prefix schema where
AliasAs prefix (Field name typ) =
Field
(prefix `AppendSymbol` "." `AppendSymbol` name)
typ
AliasAs prefix (Field name typ :> more) =
Field
(prefix `AppendSymbol` "." `AppendSymbol` name)
typ
:> AliasAs prefix more
type family ResultType query where
ResultType (Select fields `From` relation) =
ProjectionType fields (DBSchema relation)
ResultType (query `Where` conditions) = ResultType query
ResultType query =
TypeError ('Lit.Text "Malformed Query" ':$$: 'ShowType query)
type family ArgsType query where
ArgsType (_ `From` relation `Where` conditions) =
ArgsType (DBSchema relation, conditions)
ArgsType (schema, And a b) =
StripUnit (Flatten (ArgsType (schema, a) :> ArgsType (schema, b)))
ArgsType (schema, Or a b) =
StripUnit (Flatten (ArgsType (schema, a) :> ArgsType (schema, b)))
ArgsType (schema, Equals field (?)) =
ProjectionType '[field] schema
ArgsType (schema, Equals field expr) =
If
(ValidField expr schema)
(If (ValidField field schema) () (NotInSchema field schema))
(NotInSchema expr schema)
ArgsType _ = ()
type family NotInSchema field schema where
NotInSchema field schema =
TypeError (
'Lit.Text "name ("
':<>: 'ShowType field
':<>: 'Lit.Text ") not found in schema: "
':<>: 'ShowType schema
)
type family ValidField field schema where
ValidField name (Field name typ) = 'True
ValidField name (Field _ typ) = 'False
ValidField name (a :> b) = ValidField name a || ValidField name b
type family Flatten a where
Flatten ((a :> b) :> c) = Flatten (a :> b :> c)
Flatten (a :> b) = a :> Flatten b
Flatten a = a
type family StripUnit a where
StripUnit (() :> a) = StripUnit a
StripUnit (a :> ()) = StripUnit a
StripUnit (a :> b) = a :> StripUnit b
StripUnit a = a
symbolVal :: (KnownSymbol n, IsString a) => proxy n -> a
symbolVal = fromString . Lit.symbolVal
class Render query where
render :: proxy query -> Text
instance (Render fields) => Render (Select fields) where
render _proxy =
"SELECT "
<> render (Proxy @fields)
instance {-# OVERLAPS #-} (KnownSymbol field) => Render '[field] where
render _proxy = symbolVal (Proxy @field)
instance (KnownSymbol field, Render more) => Render (field:more) where
render _proxy =
symbolVal (Proxy @field) <> ", " <> render (Proxy @more)
instance (KnownSymbol (Name relation), Render proj, Table relation) => Render (From proj relation) where
render _proxy =
render (Proxy @proj)
<> " FROM "
<> symbolVal (Proxy @(Name relation))
instance (Render query, Render conditions) => Render (Where query conditions) where
render _proxy =
render (Proxy @query)
<> " WHERE "
<> render (Proxy @conditions)
instance (Render (Expr l), Render (Expr r)) => Render (Equals l r) where
render _proxy =
render (Proxy @(Expr l))
<> " = "
<> render (Proxy @(Expr r))
instance (Render l, Render r) => Render (And l r) where
render _proxy =
"( "
<> render (Proxy @l)
<> " AND "
<> render (Proxy @r)
<> " )"
instance (Render l, Render r) => Render (Or l r) where
render _proxy =
"( "
<> render (Proxy @l)
<> " AND "
<> render (Proxy @r)
<> " )"
instance Render (Expr (?)) where
render _proxy = "?"
instance (KnownSymbol a) => Render (Expr a) where
render _proxy = symbolVal (Proxy @a)
instance Render (?) where
render _proxy = "?"