git.iko.soy/rel8
on db148ff help sign in
rel8/src/Rel8/Table/NonEmpty.hs
135 lines 4.2 kB history raw
1{-# language FlexibleContexts #-}
2{-# language FlexibleInstances #-}
3{-# language MultiParamTypeClasses #-}
4{-# language NamedFieldPuns #-}
5{-# language ScopedTypeVariables #-}
6{-# language StandaloneKindSignatures #-}
7{-# language TypeApplications #-}
8{-# language TypeFamilies #-}
9{-# language UndecidableInstances #-}
11module Rel8.Table.NonEmpty
12 ( NonEmptyTable(..)
13 , nonEmptyTable, insertNonEmptyTable, nameNonEmptyTable
14 )
15where
17-- base
18import Data.Functor.Identity ( Identity( Identity ) )
19import Data.Kind ( Type )
20import Data.List.NonEmpty ( NonEmpty )
21import Data.Type.Equality ( (:~:)( Refl ) )
22import Prelude
24-- rel8
25import Rel8.Expr ( Expr, Col(..) )
26import Rel8.Expr.Array ( sappend1, snonEmptyOf )
27import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )
28import Rel8.Schema.Dict ( Dict( Dict ) )
29import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
30import Rel8.Schema.HTable.Vectorize ( happend, hvectorize )
31import Rel8.Schema.Insert ( Col( OptionalInsert, RequiredInsert ), Insert )
32import Rel8.Schema.Name ( Col( NameCol ), Name )
33import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
34import Rel8.Schema.Reify ( hreify, hunreify )
35import Rel8.Schema.Spec ( SSpec(..) )
36import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )
37import Rel8.Table
38 ( Table, Context, Columns, fromColumns, toColumns
39 , reify, unreify
40 )
41import Rel8.Table.Alternative ( AltTable, (<|>:) )
42import Rel8.Table.Eq ( EqTable, eqTable )
43import Rel8.Table.Ord ( OrdTable, ordTable )
44import Rel8.Table.Recontextualize ( Recontextualize )
45import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
46import Rel8.Table.Unreify ( Unreifiable )
49-- | A @NonEmptyTable@ value contains one or more instances of @a@. You
50-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.
51type NonEmptyTable :: Type -> Type
52newtype NonEmptyTable a =
53 NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))
56instance (Table context a, Unreifiable context a) =>
57 Table context (NonEmptyTable a)
58 where
59 type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a)
60 type Context (NonEmptyTable a) = Context a
62 fromColumns = NonEmptyTable
63 toColumns (NonEmptyTable a) = a
65 reify Refl (NonEmptyTable a) = NonEmptyTable (hreify a)
66 unreify Refl (NonEmptyTable a) = NonEmptyTable (hunreify a)
69instance
70 ( Unreifiable from a, Unreifiable to b
71 , Recontextualize from to a b
72 )
73 => Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)
76instance EqTable a => EqTable (NonEmptyTable a) where
77 eqTable =
78 hvectorize
79 (\SSpec {} (Identity dict) -> case dbTypeDict dict of
80 Dict -> case dbTypeNullity dict of
81 Null -> Dict
82 NotNull -> Dict)
83 (Identity (eqTable @a))
86instance OrdTable a => OrdTable (NonEmptyTable a) where
87 ordTable =
88 hvectorize
89 (\SSpec {} (Identity dict) -> case dbTypeDict dict of
90 Dict -> case dbTypeNullity dict of
91 Null -> Dict
92 NotNull -> Dict)
93 (Identity (ordTable @a))
96type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
99instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)
100 where
101 fromResult = fmap (fromResult @exprs) . fromColumns
102 toResult = toColumns . fmap (toResult @exprs)
105instance AltTable NonEmptyTable where
106 (<|>:) = (<>)
109instance Table Expr a => Semigroup (NonEmptyTable a) where
110 NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $
111 happend (\_ _ (DB a) (DB b) -> DB (sappend1 a b)) as bs
114nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable a
115nonEmptyTable =
116 NonEmptyTable .
117 hvectorize (\SSpec {info} -> DB . snonEmptyOf info . fmap unDB) .
118 fmap toColumns
121insertNonEmptyTable :: Table Insert a => NonEmpty a -> NonEmptyTable a
122insertNonEmptyTable =
123 NonEmptyTable .
124 hvectorize (\SSpec {necessity, info} -> case necessity of
125 SRequired -> RequiredInsert . snonEmptyOf info . fmap (\(RequiredInsert a) -> a)
126 SOptional -> OptionalInsert . fmap (snonEmptyOf info) . traverse (\(OptionalInsert a) -> a)) .
127 fmap toColumns
130nameNonEmptyTable :: Table Name a => a -> NonEmptyTable a
131nameNonEmptyTable =
132 NonEmptyTable .
133 hvectorize (\_ (Identity (NameCol a)) -> NameCol a) .
134 pure .
135 toColumns