git.iko.soy/typeable/id
on master help sign in
swap
aa466ff20 ahead, 0 behind
cabal.projectnew file+11
since splitsnapshots
unifiedsplit
@@ -0,0 +1,11 @@
1+packages:
2+ .
3+
4+-- To compile with js-backend use this:
5+source-repository-package
6+ type: git
7+ location: https://github.com/typeable/uuid.git
8+ tag: 49f50ae517de0e4d5dfbf783edc61e71cfd54d6b
9+ subdir:
10+ uuid
11+ uuid-types
id.cabal+69−28
@@ -1,36 +1,77 @@
1−cabal-version: 2.4
1+cabal-version: 2.4
2+name: id
3+version: 0.2.0.0
4+license-file: LICENSE
2
5
3−name: id
6+flag cassava
4−version: 0.1.0.0
7+ description: Enable Postgresql support
5−license-file: LICENSE
8+ default: True
9+ manual: False
10+
11+flag postgres
12+ description: Enable Postgresql support
13+ default: True
14+ manual: False
15+
16+flag flat
17+ description: Enable Flat serialization support
18+ default: True
19+ manual: False
20+
21+flag store
22+ description: Enable Data.Store serialization support
23+ default: False
24+ manual: False
25+
26+flag uuid-impl
27+ description: Include some functions with extra dependencies.
28+ Disable to reduce dependencies.
29+ default: True
30+ manual: False
6
31
7library
32library
8− exposed-modules:
33+ exposed-modules: Data.Id
9− Data.Id
10− -- other-modules:
11− -- other-extensions:
12 build-depends:
34 build-depends:
13− aeson,
35+ , aeson >=1.0
14− base >=4.12 && <5,
36+ , base >=4.12 && <5
15− binary,
37+ , binary
16− deepseq,
38+ , deepseq
17− flat,
18− hashable,
39+ , hashable
19− http-api-data,
40+ , http-api-data
20− lens,
41+ , lens
21− openapi3,
22− path-pieces,
42+ , path-pieces
23− text,
43+ , text
24− QuickCheck,
44+ , uuid-types
25− uuid,
45+ if flag(uuid-impl)
46+ build-depends:
47+ , uuid >=1.3.9
48+ cpp-options: -DUSE_UUID
49+
26− if !impl(ghcjs)
50+ if !(impl(ghcjs) || arch(javascript) || arch(wasm32))
27 build-depends:
51 build-depends:
28− cassava,
52+ , openapi3
53+ , QuickCheck
54+
55+ cpp-options: -DBACKEND
56+
57+ if (flag(postgres) && !(impl(ghcjs) || arch(javascript) || arch(wasm32)))
29− postgresql-simple,
58+ build-depends: postgresql-simple
59+ cpp-options: -DUSE_POSTGRES
60+
61+ if (flag(cassava) && !(impl(ghcjs) || arch(javascript) || arch(wasm32)))
62+ build-depends: cassava
63+ cpp-options: -DUSE_CASSAVA
64+
65+ if flag(flat)
66+ build-depends: flat >=0.4
67+ cpp-options: -DUSE_FLAT
68+
69+ if flag(store)
70+ build-depends: store
71+ cpp-options: -DUSE_STORE
72+
30− hs-source-dirs:
73+ hs-source-dirs: src
31− src
32− default-language:
74+ default-language: Haskell2010
33− Haskell2010
34 default-extensions:
75 default-extensions:
35 AllowAmbiguousTypes
76 AllowAmbiguousTypes
36 DeriveGeneric
77 DeriveGeneric
src/Data/Id.hs+93−23
@@ -7,6 +7,9 @@ module Data.Id
7 ( Id, mkId, unId, unsafeIdTagConvert, coerceId, _Id, nilId
7 ( Id, mkId, unId, unsafeIdTagConvert, coerceId, _Id, nilId
8 , IntId, mkIntId, unIntId, unsafeIntIdTagConvert, coerceIntId, _IntId
8 , IntId, mkIntId, unIntId, unsafeIntIdTagConvert, coerceIntId, _IntId
9 , Name, mkName, unName, unsafeNameTagConvert, coerceName, _Name
9 , Name, mkName, unName, unsafeNameTagConvert, coerceName, _Name
10+#ifdef USE_UUID
11+ , randomId
12+#endif
10 )
13 )
11 where
14 where
12
15
@@ -18,32 +21,52 @@ import Data.Binary (Binary)
18import Data.Coerce (coerce)
21import Data.Coerce (coerce)
19import Data.Data
22import Data.Data
20import Data.Hashable (Hashable)
23import Data.Hashable (Hashable)
21−import Data.OpenApi
22import Data.String
24import Data.String
23import Data.Text as T
25import Data.Text as T
24−import Data.UUID (UUID)
26+import Data.UUID.Types (UUID)
25−import qualified Data.UUID as UUID
27+import qualified Data.UUID.Types as UUID
26−#ifndef ghcjs_HOST_OS
27−import Database.PostgreSQL.Simple.FromField as PG (FromField)
28−import Database.PostgreSQL.Simple.ToField as PG (ToField)
29−import Data.Csv as Csv hiding(Name)
30−#endif
31−import Flat as F
32import GHC.TypeLits
28import GHC.TypeLits
33−import Test.QuickCheck
29+import Prelude as P
34import Text.ParserCombinators.ReadP
30import Text.ParserCombinators.ReadP
35import Web.HttpApiData
31import Web.HttpApiData
36import Web.PathPieces (PathPiece(..))
32import Web.PathPieces (PathPiece(..))
37
33
34+#ifdef USE_UUID
35+import qualified Data.UUID.V4 as UUID.V4
36+#endif
37+#ifdef BACKEND
38+import Data.OpenApi
39+import Test.QuickCheck
40+#ifdef USE_CASSAVA
41+import Data.Csv as Csv hiding(Name)
42+#endif
43+#ifdef USE_POSTGRES
44+import Database.PostgreSQL.Simple.FromField as PG (FromField)
45+import Database.PostgreSQL.Simple.ToField as PG (ToField)
46+#endif
47+#endif
48+
49+#ifdef USE_FLAT
50+import Flat as F
51+#endif
52+#ifdef USE_STORE
53+import qualified Data.Store
54+#endif
55+
38newtype Id t = Id { unId :: UUID }
56newtype Id t = Id { unId :: UUID }
39 deriving stock Data
57 deriving stock Data
40 deriving newtype
58 deriving newtype
41 ( Eq, Ord, Binary
59 ( Eq, Ord, Binary
42#ifndef ghcjs_HOST_OS
60#ifndef ghcjs_HOST_OS
61+#ifdef USE_POSTGRES
43 , PG.ToField, PG.FromField
62 , PG.ToField, PG.FromField
44#endif
63#endif
64+#endif
45− , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
65+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey
66+#ifdef BACKEND
67+ , ToSchema, ToParamSchema
68+#endif
46− , ToParamSchema, FromHttpApiData, ToHttpApiData )
69+ , FromHttpApiData, ToHttpApiData )
47
70
48type role Id nominal
71type role Id nominal
49
72
@@ -53,25 +76,42 @@ mkId :: forall s. UUID -> Id s
53mkId = coerce
76mkId = coerce
54{-# INLINE mkId #-}
77{-# INLINE mkId #-}
55
78
79+#ifdef USE_UUID
80+randomId :: forall s. IO (Id s)
81+randomId = coerce <$> UUID.V4.nextRandom
82+{-# INLINE randomId #-}
83+#endif
84+
56instance KnownSymbol s => Show (Id s) where
85instance KnownSymbol s => Show (Id s) where
57− show (Id v) = "Id-" <> symbolVal (Proxy @s) <> "-" <> show v
86+ show (Id v) = "Id-" <> symbolVal (Proxy @s) <> "-" <> P.show v
58
87
59instance KnownSymbol s => Read (Id s) where
88instance KnownSymbol s => Read (Id s) where
60 readsPrec _ = readP_to_S $ do
89 readsPrec _ = readP_to_S $ do
61 _ <- string ("Id-" <> symbolVal (Proxy @s) <> "-")
90 _ <- string ("Id-" <> symbolVal (Proxy @s) <> "-")
62 mkId <$> readS_to_P reads
91 mkId <$> readS_to_P reads
63
92
93+#ifdef USE_FLAT
64instance Flat (Id s) where
94instance Flat (Id s) where
65 encode = F.encode . UUID.toWords . coerce
95 encode = F.encode . UUID.toWords . coerce
66 decode = coerce . (\(a,b,c,d) -> UUID.fromWords a b c d) <$> F.decode
96 decode = coerce . (\(a,b,c,d) -> UUID.fromWords a b c d) <$> F.decode
67 size = F.size . UUID.toWords . coerce
97 size = F.size . UUID.toWords . coerce
98+#endif
68
99
100+#ifdef USE_STORE
101+instance Data.Store.Store (Id s) where
102+ poke = Data.Store.poke . UUID.toWords . coerce
103+ peek = coerce . (\(a,b,c,d) -> UUID.fromWords a b c d) <$> Data.Store.peek
104+ size = Data.Store.ConstSize 16
105+#endif
106+
107+#ifdef BACKEND
69instance Arbitrary (Id t) where
108instance Arbitrary (Id t) where
70 arbitrary = fmap Id $ UUID.fromWords
109 arbitrary = fmap Id $ UUID.fromWords
71 <$> arbitrary
110 <$> arbitrary
72 <*> arbitrary
111 <*> arbitrary
73 <*> arbitrary
112 <*> arbitrary
74 <*> arbitrary
113 <*> arbitrary
114+#endif
75
115
76instance PathPiece (Id t) where
116instance PathPiece (Id t) where
77 fromPathPiece = coerce . UUID.fromText
117 fromPathPiece = coerce . UUID.fromText
@@ -79,12 +119,14 @@ instance PathPiece (Id t) where
79
119
80#ifndef ghcjs_HOST_OS
120#ifndef ghcjs_HOST_OS
81
121
122+#ifdef USE_CASSAVA
82instance Csv.FromField (Id tag) where
123instance Csv.FromField (Id tag) where
83 parseField = parseField
124 parseField = parseField
84 >=> fmap mkId . maybe (fail "invalid UUID in CSV") pure . UUID.fromText
125 >=> fmap mkId . maybe (fail "invalid UUID in CSV") pure . UUID.fromText
85
126
86instance Csv.ToField (Id tag) where
127instance Csv.ToField (Id tag) where
87 toField = Csv.toField . UUID.toText . coerce
128 toField = Csv.toField . UUID.toText . coerce
129+#endif
88
130
89#endif
131#endif
90
132
@@ -111,11 +153,24 @@ newtype IntId t = IntId { unIntId :: Integer }
111 deriving newtype
153 deriving newtype
112 ( Eq, Ord, Binary
154 ( Eq, Ord, Binary
113#ifndef ghcjs_HOST_OS
155#ifndef ghcjs_HOST_OS
156+#ifdef USE_POSTGRES
157+ , PG.ToField, PG.FromField
158+#endif
159+#ifdef USE_CASSAVA
114− , PG.ToField, PG.FromField, Csv.ToField, Csv.FromField
160+ , Csv.ToField, Csv.FromField
115#endif
161#endif
162+#endif
163+#ifdef USE_FLAT
164+ , Flat
165+#endif
166+#ifdef USE_STORE
167+ , Data.Store.Store
168+#endif
169+#ifdef BACKEND
170+ , ToSchema, ToParamSchema, Arbitrary
171+#endif
116− , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
172+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, FromHttpApiData
117− , ToParamSchema, FromHttpApiData, ToHttpApiData, PathPiece, Flat, Arbitrary
118− , Num, Integral, Real, Enum )
173+ , ToHttpApiData, PathPiece, Num, Integral, Real, Enum )
119
174
120type role IntId nominal
175type role IntId nominal
121
176
@@ -126,7 +181,7 @@ mkIntId = coerce
126{-# INLINE mkIntId #-}
181{-# INLINE mkIntId #-}
127
182
128instance KnownSymbol s => Show (IntId s) where
183instance KnownSymbol s => Show (IntId s) where
129− show (IntId v) = "IntId-" <> symbolVal (Proxy @s) <> "-" <> show v
184+ show (IntId v) = "IntId-" <> symbolVal (Proxy @s) <> "-" <> P.show v
130
185
131instance KnownSymbol s => Read (IntId s) where
186instance KnownSymbol s => Read (IntId s) where
132 readsPrec _ = readP_to_S $ do
187 readsPrec _ = readP_to_S $ do
@@ -149,11 +204,24 @@ newtype Name t = Name { unName :: Text }
149 deriving newtype
204 deriving newtype
150 ( Eq, Ord, Binary
205 ( Eq, Ord, Binary
151#ifndef ghcjs_HOST_OS
206#ifndef ghcjs_HOST_OS
207+#ifdef USE_POSTGRES
208+ , PG.ToField, PG.FromField
209+#endif
210+#ifdef USE_CASSAVA
152− , PG.ToField, PG.FromField, Csv.ToField, Csv.FromField
211+ , Csv.ToField, Csv.FromField
153#endif
212#endif
213+#endif
214+#ifdef USE_FLAT
215+ , Flat
216+#endif
217+#ifdef USE_STORE
218+ , Data.Store.Store
219+#endif
220+#ifdef BACKEND
221+ , ToSchema, ToParamSchema
222+#endif
154− , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
223+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, FromHttpApiData
155− , ToParamSchema, FromHttpApiData, ToHttpApiData, PathPiece, Flat
156− , IsString, Semigroup, Monoid )
224+ , ToHttpApiData, PathPiece, IsString, Semigroup, Monoid )
157
225
158type role Name nominal
226type role Name nominal
159
227
@@ -164,15 +232,17 @@ mkName = coerce
164{-# INLINE mkName #-}
232{-# INLINE mkName #-}
165
233
166instance KnownSymbol s => Show (Name s) where
234instance KnownSymbol s => Show (Name s) where
167− show (Name v) = "Name-" <> symbolVal (Proxy @s) <> "-" <> show v
235+ show (Name v) = "Name-" <> symbolVal (Proxy @s) <> "-" <> P.show v
168
236
169instance KnownSymbol s => Read (Name s) where
237instance KnownSymbol s => Read (Name s) where
170 readsPrec _ = readP_to_S $ do
238 readsPrec _ = readP_to_S $ do
171 _ <- string ("Name-" <> symbolVal (Proxy @s) <> "-")
239 _ <- string ("Name-" <> symbolVal (Proxy @s) <> "-")
172 mkName <$> readS_to_P reads
240 mkName <$> readS_to_P reads
173
241
242+#ifdef BACKEND
174instance Arbitrary (Name s) where
243instance Arbitrary (Name s) where
175 arbitrary = coerce . T.pack . getPrintableString <$> arbitrary
244 arbitrary = coerce . T.pack . getPrintableString <$> arbitrary
245+#endif
176
246
177-- | This is a more \"explicit\" 'coerce' specifically for 'Name'.
247-- | This is a more \"explicit\" 'coerce' specifically for 'Name'.
178-- You are forced to explicitly specify the phantom types you are converting
248-- You are forced to explicitly specify the phantom types you are converting