@@ -4,64 +4,252 @@
44{-# OPTIONS_GHC -Wno-orphans #-}
55
66module Data.Id
7− ( Id(..)
8− , coerceId
9− , _Id
10− ) where
7+ ( Id, mkId, unId, unsafeIdTagConvert, coerceId, _Id, nilId
8+ , IntId, mkIntId, unIntId, unsafeIntIdTagConvert, coerceIntId, _IntId
9+ , Name, mkName, unName, unsafeNameTagConvert, coerceName, _Name
10+#ifdef USE_UUID
11+ , randomId
12+#endif
13+ )
14+ where
1115
1216import Control.DeepSeq (NFData)
1317import Control.Lens
18+import Control.Monad
1419import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
1520import Data.Binary (Binary)
1621import Data.Coerce (coerce)
1722import Data.Data
1823import Data.Hashable (Hashable)
19−import Data.OpenApi
20−import Data.UUID (UUID)
21−import qualified Data.UUID as UUID
22−#ifndef ghcjs_HOST_OS
23−import Database.PostgreSQL.Simple.FromField (FromField)
24−import Database.PostgreSQL.Simple.ToField (ToField)
25−#endif
26−import GHC.Generics (Generic)
27−import Test.QuickCheck
24+import Data.String
25+import Data.Text as T
26+import Data.UUID.Types (UUID)
27+import qualified Data.UUID.Types as UUID
28+import GHC.TypeLits
29+import Prelude as P
30+import Text.ParserCombinators.ReadP
2831import Web.HttpApiData
2932import Web.PathPieces (PathPiece(..))
3033
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+
3156newtype Id t = Id { unId :: UUID }
32− deriving
33− ( Eq, Ord, Generic, Read, Show, Data
57+ deriving stock Data
58+ deriving newtype
59+ ( Eq, Ord, Binary
3460#ifndef ghcjs_HOST_OS
35− , ToField, FromField
61+#ifdef USE_POSTGRES
62+ , PG.ToField, PG.FromField
63+#endif
64+#endif
65+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey
66+#ifdef BACKEND
67+ , ToSchema, ToParamSchema
3668#endif
37− , PathPiece, FromJSON
38− , ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema, ToParamSchema
3969 , FromHttpApiData, ToHttpApiData )
4070
4171type role Id nominal
4272
73+makePrisms ''Id
74+
75+mkId :: forall s. UUID -> Id s
76+mkId = coerce
77+{-# INLINE mkId #-}
78+
79+#ifdef USE_UUID
80+randomId :: forall s. IO (Id s)
81+randomId = coerce <$> UUID.V4.nextRandom
82+{-# INLINE randomId #-}
83+#endif
84+
85+instance KnownSymbol s => Show (Id s) where
86+ show (Id v) = "Id-" <> symbolVal (Proxy @s) <> "-" <> P.show v
87+
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
92+
93+#ifdef USE_FLAT
94+instance Flat (Id s) where
95+ encode = F.encode . UUID.toWords . coerce
96+ decode = coerce . (\(a,b,c,d) -> UUID.fromWords a b c d) <$> F.decode
97+ size = F.size . UUID.toWords . coerce
98+#endif
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
43108instance Arbitrary (Id t) where
44109 arbitrary = fmap Id $ UUID.fromWords
45110 <$> arbitrary
46111 <*> arbitrary
47112 <*> arbitrary
48113 <*> arbitrary
114+#endif
49115
50−instance Binary (Id t) where
116+instance PathPiece (Id t) where
117+ fromPathPiece = coerce . UUID.fromText
118+ toPathPiece = UUID.toText . coerce
51119
52−instance PathPiece UUID.UUID where
53− fromPathPiece = UUID.fromText
54− toPathPiece = UUID.toText
120+#ifndef ghcjs_HOST_OS
55121
56−makePrisms ''Id
122+#ifdef USE_CASSAVA
123+instance Csv.FromField (Id tag) where
124+ parseField = parseField
125+ >=> fmap mkId . maybe (fail "invalid UUID in CSV") pure . UUID.fromText
126+
127+instance Csv.ToField (Id tag) where
128+ toField = Csv.toField . UUID.toText . coerce
129+#endif
130+
131+#endif
57132
58133-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
59134-- You are forced to explicitly specify the phantom types you are converting
60135-- via the @TypeApplications@ compiler extension.
61−coerceId :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
136+coerceId, unsafeIdTagConvert :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
62137coerceId = coerce
63138{-# INLINE coerceId #-}
139+unsafeIdTagConvert = coerce
140+{-# INLINE unsafeIdTagConvert #-}
64141
142+-- | Id corresponding to UUID nil. Useful for testing etc.
143+nilId :: forall a. Id (Ambiguous a)
144+nilId = Id UUID.nil
145+{-# INLINE nilId #-}
65146-- https://kcsongor.github.io/ambiguous-tags/
66147type family Ambiguous (a :: k) :: j where
67148 Ambiguous x = x
149+
150+----------------- IntId
151+newtype IntId t = IntId { unIntId :: Integer }
152+ deriving stock Data
153+ deriving newtype
154+ ( Eq, Ord, Binary
155+#ifndef ghcjs_HOST_OS
156+#ifdef USE_POSTGRES
157+ , PG.ToField, PG.FromField
158+#endif
159+#ifdef USE_CASSAVA
160+ , Csv.ToField, Csv.FromField
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
172+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, FromHttpApiData
173+ , ToHttpApiData, PathPiece, Num, Integral, Real, Enum )
174+
175+type role IntId nominal
176+
177+makePrisms ''IntId
178+
179+mkIntId :: forall s. Integer -> IntId s
180+mkIntId = coerce
181+{-# INLINE mkIntId #-}
182+
183+instance KnownSymbol s => Show (IntId s) where
184+ show (IntId v) = "IntId-" <> symbolVal (Proxy @s) <> "-" <> P.show v
185+
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
190+
191+-- | This is a more \"explicit\" 'coerce' specifically for 'IntId'.
192+-- You are forced to explicitly specify the phantom types you are converting
193+-- via the @TypeApplications@ compiler extension.
194+coerceIntId, unsafeIntIdTagConvert
195+ :: forall a b. IntId (Ambiguous a) -> IntId (Ambiguous b)
196+coerceIntId = coerce
197+{-# INLINE coerceIntId #-}
198+unsafeIntIdTagConvert = coerce
199+{-# INLINE unsafeIntIdTagConvert #-}
200+
201+----------------- Name
202+newtype Name t = Name { unName :: Text }
203+ deriving stock Data
204+ deriving newtype
205+ ( Eq, Ord, Binary
206+#ifndef ghcjs_HOST_OS
207+#ifdef USE_POSTGRES
208+ , PG.ToField, PG.FromField
209+#endif
210+#ifdef USE_CASSAVA
211+ , Csv.ToField, Csv.FromField
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
223+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, FromHttpApiData
224+ , ToHttpApiData, PathPiece, IsString, Semigroup, Monoid )
225+
226+type role Name nominal
227+
228+makePrisms ''Name
229+
230+mkName :: forall s. Text -> Name s
231+mkName = coerce
232+{-# INLINE mkName #-}
233+
234+instance KnownSymbol s => Show (Name s) where
235+ show (Name v) = "Name-" <> symbolVal (Proxy @s) <> "-" <> P.show v
236+
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
241+
242+#ifdef BACKEND
243+instance Arbitrary (Name s) where
244+ arbitrary = coerce . T.pack . getPrintableString <$> arbitrary
245+#endif
246+
247+-- | This is a more \"explicit\" 'coerce' specifically for 'Name'.
248+-- You are forced to explicitly specify the phantom types you are converting
249+-- via the @TypeApplications@ compiler extension.
250+coerceName, unsafeNameTagConvert
251+ :: forall a b. Name (Ambiguous a) -> Name (Ambiguous b)
252+coerceName = coerce
253+{-# INLINE coerceName #-}
254+unsafeNameTagConvert = coerce
255+{-# INLINE unsafeNameTagConvert #-}