git.iko.soy/rel8
on fb4e1a5 help sign in
rel8/src/Rel8/Type/Array1D.hs
136 lines 3.8 kB history raw
1{-# language DataKinds #-}
2{-# language DeriveTraversable #-}
3{-# language DerivingStrategies #-}
4{-# language GeneralizedNewtypeDeriving #-}
5{-# language NamedFieldPuns #-}
6{-# language StandaloneKindSignatures #-}
7{-# language TypeFamilies #-}
8{-# language UndecidableInstances #-}
10{-# options_ghc -fno-warn-redundant-constraints #-}
12module Rel8.Type.Array1D
13 ( Array1D( Array1D )
14 , getArray1D
15 )
16where
18-- aeson
19import Data.Aeson
20 ( ToJSON
21 , ToJSON1
22 , ToJSONKey
23 , FromJSON
24 , FromJSON1
25 , FromJSONKey
26 )
28-- base
29import Control.Applicative ( Alternative, (<|>) )
30import Control.Monad ( MonadPlus )
31import Data.Functor.Classes ( Eq1, Ord1, Read1, Show1 )
32import Data.Kind ( Type )
33import GHC.Exts ( IsList )
34import Prelude hiding ( null )
36-- hasql
37import qualified Hasql.Decoders as Hasql
39-- opaleye
40import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
42-- rel8
43import Rel8.Expr.Opaleye ( zipPrimExprsWith )
44import Rel8.Expr.Serialize ( litExpr )
45import Rel8.Schema.Nullability
46 ( Unnullify
47 , Nullability( Nullable, NonNullable )
48 , Sql, nullabilization
49 )
50import Rel8.Type ( DBType, typeInformation )
51import Rel8.Type.Eq ( DBEq )
52import Rel8.Type.Information ( TypeInformation(..) )
53import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
54import Rel8.Type.Ord ( DBMax, DBMin, DBOrd )
55import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
57-- semigroupoids
58import Data.Functor.Alt ( Alt, (<!>) )
59import Data.Functor.Apply ( Apply )
60import Data.Functor.Bind ( Bind )
61import Data.Functor.Plus ( Plus )
63-- semialign
64import Data.Align ( Align )
65import Data.Semialign ( Semialign )
66import Data.Zip ( Repeat, Unzip, Zip )
69-- | A one dimensional array.
70newtype Array1D a = Array1D [a]
71 deriving stock Traversable
72 deriving newtype
73 ( Eq, Ord, Read, Show, Semigroup, Monoid, IsList
74 , Functor, Foldable
75 , Eq1, Ord1, Read1, Show1
76 , FromJSON1, ToJSON1, FromJSON, FromJSONKey, ToJSON, ToJSONKey
77 , Apply, Applicative, Alternative, Plus, Bind, Monad, MonadPlus
78 , Align, Semialign, Repeat, Unzip, Zip
79 )
82instance Alt Array1D where
83 (<!>) = (<|>)
86getArray1D :: Array1D a -> [a]
87getArray1D (Array1D a) = a
90type IsArray1D :: Type -> Bool
91type family IsArray1D a where
92 IsArray1D (Array1D _) = 'True
93 IsArray1D _ = 'False
96array1DTypeInformation :: IsArray1D (Unnullify a) ~ 'False
97 => Nullability a
98 -> TypeInformation (Unnullify a)
99 -> TypeInformation (Array1D a)
100array1DTypeInformation nullability info =
101 case info of
102 TypeInformation{ encode, decode, typeName } -> TypeInformation
103 { decode = case nullability of
104 Nullable -> Array1D <$> Hasql.listArray (Hasql.nullable decode)
105 NonNullable -> Array1D <$> Hasql.listArray (Hasql.nonNullable decode)
106 , encode = case nullability of
107 Nullable -> Opaleye.ArrayExpr . fmap (maybe null encode) . getArray1D
108 NonNullable -> Opaleye.ArrayExpr . fmap encode . getArray1D
109 , typeName = typeName <> "[]"
110 }
111 where
112 null = Opaleye.ConstExpr Opaleye.NullLit
115instance (Sql DBType a, IsArray1D (Unnullify a) ~ 'False) => DBType (Array1D a) where
116 typeInformation = array1DTypeInformation nullabilization typeInformation
119instance (Sql DBEq a, IsArray1D (Unnullify a) ~ 'False) => DBEq (Array1D a)
122instance (Sql DBOrd a, IsArray1D (Unnullify a) ~ 'False) => DBOrd (Array1D a)
125instance (Sql DBMax a, IsArray1D (Unnullify a) ~ 'False) => DBMax (Array1D a)
128instance (Sql DBMin a, IsArray1D (Unnullify a) ~ 'False) => DBMin (Array1D a)
131instance (Sql DBType a, IsArray1D (Unnullify a) ~ 'False) => DBSemigroup (Array1D a) where
132 (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
135instance (Sql DBType a, IsArray1D (Unnullify a) ~ 'False) => DBMonoid (Array1D a) where
136 memptyExpr = litExpr mempty