@@ -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
@@ -18,31 +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)
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
28+import GHC.TypeLits
30+import Text.ParserCombinators.ReadP
31+import Web.HttpApiData
32+import Web.PathPieces (PathPiece(..))
35+import qualified Data.UUID.V4 as UUID.V4
39+import Test.QuickCheck
41+import Data.Csv as Csv hiding(Name)
27import Database.PostgreSQL.Simple.FromField as PG (FromField)
44import Database.PostgreSQL.Simple.FromField as PG (FromField)
28import Database.PostgreSQL.Simple.ToField as PG (ToField)
45import Database.PostgreSQL.Simple.ToField as PG (ToField)
29−import Data.Csv as Csv hiding(Name)
31import Flat as F
50import Flat as F
32−import GHC.TypeLits
51+#endif
33−import Test.QuickCheck
52+#ifdef USE_STORE
34−import Web.HttpApiData
53+import qualified Data.Store
35−import Web.PathPieces (PathPiece(..))
54+#endif
37newtype Id t = Id { unId :: UUID }
56newtype Id t = Id { unId :: UUID }
38 deriving stock Data
57 deriving stock Data
39 deriving newtype
58 deriving newtype
40 ( Eq, Ord, Binary
59 ( Eq, Ord, Binary
41#ifndef ghcjs_HOST_OS
60#ifndef ghcjs_HOST_OS
42 , PG.ToField, PG.FromField
62 , PG.ToField, PG.FromField
44− , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
65+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey
67+ , ToSchema, ToParamSchema
45− , ToParamSchema, FromHttpApiData, ToHttpApiData )
69+ , FromHttpApiData, ToHttpApiData )
47type role Id nominal
71type role Id nominal
@@ -52,20 +76,42 @@ mkId :: forall s. UUID -> Id s
52mkId = coerce
76mkId = coerce
53{-# INLINE mkId #-}
77{-# INLINE mkId #-}
80+randomId :: forall s. IO (Id s)
81+randomId = coerce <$> UUID.V4.nextRandom
82+{-# INLINE randomId #-}
55instance KnownSymbol s => Show (Id s) where
85instance KnownSymbol s => Show (Id s) where
56− show (Id v) = "Id-" <> symbolVal (Proxy @s) <> "-" <> show v
86+ show (Id v) = "Id-" <> symbolVal (Proxy @s) <> "-" <> P.show v
88+instance KnownSymbol s => Read (Id s) where
89+ readsPrec _ = readP_to_S $ do
90+ _ <- string ("Id-" <> symbolVal (Proxy @s) <> "-")
91+ mkId <$> readS_to_P reads
58instance Flat (Id s) where
94instance Flat (Id s) where
59 encode = F.encode . UUID.toWords . coerce
95 encode = F.encode . UUID.toWords . coerce
60 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
61 size = F.size . UUID.toWords . coerce
97 size = F.size . UUID.toWords . coerce
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
63instance Arbitrary (Id t) where
108instance Arbitrary (Id t) where
64 arbitrary = fmap Id $ UUID.fromWords
109 arbitrary = fmap Id $ UUID.fromWords
65 <$> arbitrary
110 <$> arbitrary
66 <*> arbitrary
111 <*> arbitrary
67 <*> arbitrary
112 <*> arbitrary
68 <*> arbitrary
113 <*> arbitrary
70instance PathPiece (Id t) where
116instance PathPiece (Id t) where
71 fromPathPiece = coerce . UUID.fromText
117 fromPathPiece = coerce . UUID.fromText
@@ -73,12 +119,14 @@ instance PathPiece (Id t) where
74#ifndef ghcjs_HOST_OS
120#ifndef ghcjs_HOST_OS
76instance Csv.FromField (Id tag) where
123instance Csv.FromField (Id tag) where
77 parseField = parseField
124 parseField = parseField
78 >=> fmap mkId . maybe (fail "invalid UUID in CSV") pure . UUID.fromText
125 >=> fmap mkId . maybe (fail "invalid UUID in CSV") pure . UUID.fromText
80instance Csv.ToField (Id tag) where
127instance Csv.ToField (Id tag) where
81 toField = Csv.toField . UUID.toText . coerce
128 toField = Csv.toField . UUID.toText . coerce
@@ -105,11 +153,24 @@ newtype IntId t = IntId { unIntId :: Integer }
105 deriving newtype
153 deriving newtype
106 ( Eq, Ord, Binary
154 ( Eq, Ord, Binary
107#ifndef ghcjs_HOST_OS
155#ifndef ghcjs_HOST_OS
157+ , PG.ToField, PG.FromField
108− , PG.ToField, PG.FromField, Csv.ToField, Csv.FromField
160+ , Csv.ToField, Csv.FromField
170+ , ToSchema, ToParamSchema, Arbitrary
110− , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
172+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, FromHttpApiData
111− , ToParamSchema, FromHttpApiData, ToHttpApiData, PathPiece, Flat, Arbitrary
112− , Num, Integral, Real, Enum )
173+ , ToHttpApiData, PathPiece, Num, Integral, Real, Enum )
114type role IntId nominal
175type role IntId nominal
@@ -120,7 +181,12 @@ mkIntId = coerce
120{-# INLINE mkIntId #-}
181{-# INLINE mkIntId #-}
122instance KnownSymbol s => Show (IntId s) where
183instance KnownSymbol s => Show (IntId s) where
123− show (IntId v) = "IntId-" <> symbolVal (Proxy @s) <> "-" <> show v
184+ show (IntId v) = "IntId-" <> symbolVal (Proxy @s) <> "-" <> P.show v
186+instance KnownSymbol s => Read (IntId s) where
187+ readsPrec _ = readP_to_S $ do
188+ _ <- string ("IntId-" <> symbolVal (Proxy @s) <> "-")
189+ mkIntId <$> readS_to_P reads
125-- | This is a more \"explicit\" 'coerce' specifically for 'IntId'.
191-- | This is a more \"explicit\" 'coerce' specifically for 'IntId'.
126-- You are forced to explicitly specify the phantom types you are converting
192-- You are forced to explicitly specify the phantom types you are converting
@@ -138,11 +204,24 @@ newtype Name t = Name { unName :: Text }
138 deriving newtype
204 deriving newtype
139 ( Eq, Ord, Binary
205 ( Eq, Ord, Binary
140#ifndef ghcjs_HOST_OS
206#ifndef ghcjs_HOST_OS
208+ , PG.ToField, PG.FromField
141− , PG.ToField, PG.FromField, Csv.ToField, Csv.FromField
211+ , Csv.ToField, Csv.FromField
221+ , ToSchema, ToParamSchema
143− , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
223+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, FromHttpApiData
144− , ToParamSchema, FromHttpApiData, ToHttpApiData, PathPiece, Flat
145− , IsString, Semigroup, Monoid )
224+ , ToHttpApiData, PathPiece, IsString, Semigroup, Monoid )
147type role Name nominal
226type role Name nominal
@@ -153,10 +232,17 @@ mkName = coerce
153{-# INLINE mkName #-}
232{-# INLINE mkName #-}
155instance KnownSymbol s => Show (Name s) where
234instance KnownSymbol s => Show (Name s) where
156− show (Name v) = "Name-" <> symbolVal (Proxy @s) <> "-" <> show v
235+ show (Name v) = "Name-" <> symbolVal (Proxy @s) <> "-" <> P.show v
237+instance KnownSymbol s => Read (Name s) where
238+ readsPrec _ = readP_to_S $ do
239+ _ <- string ("Name-" <> symbolVal (Proxy @s) <> "-")
240+ mkName <$> readS_to_P reads
158instance Arbitrary (Name s) where
243instance Arbitrary (Name s) where
159 arbitrary = coerce . T.pack . getPrintableString <$> arbitrary
244 arbitrary = coerce . T.pack . getPrintableString <$> arbitrary
161-- | This is a more \"explicit\" 'coerce' specifically for 'Name'.
247-- | This is a more \"explicit\" 'coerce' specifically for 'Name'.
162-- 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