{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE Rank2Types #-}
module Opaleye.Internal.Table where
import Opaleye.Internal.Column (Column(Column), unColumn)
import qualified Opaleye.Internal.Tag as Tag
import qualified Opaleye.Internal.Unpackspec as U
import qualified Opaleye.Internal.PrimQuery as PQ
import qualified Opaleye.Internal.PackMap as PM
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import qualified Data.Functor.Identity as I
import Data.Profunctor (Profunctor, dimap, lmap)
import Data.Profunctor.Product (ProductProfunctor, empty, (***!))
import qualified Data.Profunctor.Product as PP
import qualified Data.List.NonEmpty as NEL
import Data.Monoid (Monoid, mempty, mappend)
import Data.Semigroup (Semigroup, (<>))
import Control.Applicative (Applicative, pure, (<*>), liftA2)
import qualified Control.Arrow as Arr
data Table writerColumns viewColumns
= Table String (TableFields writerColumns viewColumns)
| TableWithSchema String String (TableFields writerColumns viewColumns)
tableIdentifier :: Table writeColumns viewColumns -> PQ.TableIdentifier
tableIdentifier (Table t _) = PQ.TableIdentifier Nothing t
tableIdentifier (TableWithSchema s t _) = PQ.TableIdentifier (Just s) t
tableColumns :: Table writeColumns viewColumns -> TableFields writeColumns viewColumns
tableColumns (Table _ p) = p
tableColumns (TableWithSchema _ _ p) = p
tableProperties :: Table writeColumns viewColumns -> TableFields writeColumns viewColumns
tableProperties = tableColumns
data TableProperties writeColumns viewColumns = TableProperties
{ tablePropertiesWriter :: Writer writeColumns viewColumns
, tablePropertiesView :: View viewColumns }
type TableColumns = TableProperties
type TableFields = TableProperties
tableColumnsWriter :: TableFields writeColumns viewColumns
-> Writer writeColumns viewColumns
tableColumnsWriter = tablePropertiesWriter
tableColumnsView :: TableFields writeColumns viewColumns
-> View viewColumns
tableColumnsView = tablePropertiesView
data View columns = View columns
newtype Writer columns dummy =
Writer (forall f. Functor f =>
PM.PackMap (f HPQ.PrimExpr, String) () (f columns) ())
required :: String -> TableFields (Column a) (Column a)
required columnName = TableProperties
(requiredW columnName)
(View (Column (HPQ.BaseTableAttrExpr columnName)))
optional :: String -> TableFields (Maybe (Column a)) (Column a)
optional columnName = TableProperties
(optionalW columnName)
(View (Column (HPQ.BaseTableAttrExpr columnName)))
class TableColumn writeType sqlType | writeType -> sqlType where
tableColumn :: String -> TableFields writeType (Column sqlType)
instance TableColumn (Column a) a where
tableColumn = required
instance TableColumn (Maybe (Column a)) a where
tableColumn = optional
tableField :: TableColumn writeType sqlType
=> String -> TableFields writeType (Column sqlType)
tableField = tableColumn
queryTable :: U.Unpackspec viewColumns columns
-> Table writeColumns viewColumns
-> Tag.Tag
-> (columns, PQ.PrimQuery)
queryTable cm table tag = (primExprs, primQ) where
View tableCols = tableColumnsView (tableColumns table)
(primExprs, projcols) = runColumnMaker cm tag tableCols
primQ :: PQ.PrimQuery
primQ = PQ.BaseTable (tableIdentifier table) projcols
runColumnMaker :: U.Unpackspec tablecolumns columns
-> Tag.Tag
-> tablecolumns
-> (columns, [(HPQ.Symbol, HPQ.PrimExpr)])
runColumnMaker cm tag tableCols = PM.run (U.runUnpackspec cm f tableCols) where
f = PM.extractAttrPE mkName tag
mkName pe i = (++ i) $ case pe of
HPQ.BaseTableAttrExpr columnName -> columnName
HPQ.CompositeExpr columnExpr fieldName -> mkName columnExpr i ++ fieldName
_ -> "tablecolumn"
runWriter :: Writer columns columns' -> columns -> [(HPQ.PrimExpr, String)]
runWriter (Writer (PM.PackMap f)) columns = outColumns
where (outColumns, ()) = f extract (I.Identity columns)
extract (pes, s) = ([(I.runIdentity pes, s)], ())
runWriter' :: Writer columns columns' -> NEL.NonEmpty columns -> (NEL.NonEmpty [HPQ.PrimExpr], [String])
runWriter' (Writer (PM.PackMap f)) columns = Arr.first unZip outColumns
where (outColumns, ()) = f extract columns
extract (pes, s) = ((Zip (fmap return pes), [s]), ())
newtype Zip a = Zip { unZip :: NEL.NonEmpty [a] }
instance Semigroup (Zip a) where
Zip xs <> Zip ys = Zip (NEL.zipWith (++) xs ys)
instance Monoid (Zip a) where
mempty = Zip mempty'
where mempty' = [] `NEL.cons` mempty'
mappend = (<>)
requiredW :: String -> Writer (Column a) (Column a)
requiredW columnName =
Writer (PM.iso (flip (,) columnName . fmap unColumn) id)
optionalW :: String -> Writer (Maybe (Column a)) (Column a)
optionalW columnName =
Writer (PM.iso (flip (,) columnName . fmap maybeUnColumn) id)
where maybeUnColumn = maybe HPQ.DefaultInsertExpr unColumn
instance Functor (Writer a) where
fmap _ (Writer g) = Writer g
instance Applicative (Writer a) where
pure x = Writer (fmap (const ()) (pure x))
Writer f <*> Writer x = Writer (liftA2 (\_ _ -> ()) f x)
instance Profunctor Writer where
dimap f _ (Writer h) = Writer (lmap (fmap f) h)
instance ProductProfunctor Writer where
empty = PP.defaultEmpty
(***!) = PP.defaultProfunctorProduct
instance Functor (TableProperties a) where
fmap f (TableProperties w (View v)) = TableProperties (fmap f w) (View (f v))
instance Applicative (TableProperties a) where
pure x = TableProperties (pure x) (View x)
TableProperties fw (View fv) <*> TableProperties xw (View xv) =
TableProperties (fw <*> xw) (View (fv xv))
instance Profunctor TableProperties where
dimap f g (TableProperties w (View v)) = TableProperties (dimap f g w)
(View (g v))
instance ProductProfunctor TableProperties where
empty = PP.defaultEmpty
(***!) = PP.defaultProfunctorProduct
instance Functor (Table a) where
fmap f (Table t tp) = Table t (fmap f tp)
fmap f (TableWithSchema s t tp) = TableWithSchema s t (fmap f tp)
instance Profunctor Table where
dimap f g (Table t tp) = Table t (dimap f g tp)
dimap f g (TableWithSchema s t tp) = TableWithSchema s t (dimap f g tp)