@@ -4,64 +4,140 @@
44{-# OPTIONS_GHC -Wno-orphans #-}
55
66module Data.Id
7− ( Id(..)
8− , coerceId
9− , nilId
10− , _Id
11− ) 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
1215
1316import Control.DeepSeq (NFData)
1417import Control.Lens
18+import Control.Monad
1519import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
1620import Data.Binary (Binary)
1721import Data.Coerce (coerce)
1822import Data.Data
1923import Data.Hashable (Hashable)
20−import Data.OpenApi
21−import Data.UUID (UUID)
22−import qualified Data.UUID as UUID
23−#ifndef ghcjs_HOST_OS
24−import Database.PostgreSQL.Simple.FromField (FromField)
25−import Database.PostgreSQL.Simple.ToField (ToField)
26−#endif
27−import GHC.Generics (Generic)
28−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
2931import Web.HttpApiData
3032import Web.PathPieces (PathPiece(..))
3133
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+
3256newtype Id t = Id { unId :: UUID }
33− deriving
34− ( Eq, Ord, Generic, Read, Show, Data
57+ deriving stock Data
58+ deriving newtype
59+ ( Eq, Ord, Binary
3560#ifndef ghcjs_HOST_OS
36− , 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
3768#endif
38− , PathPiece, FromJSON
39− , ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema, ToParamSchema
4069 , FromHttpApiData, ToHttpApiData )
4170
4271type role Id nominal
4372
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
44108instance Arbitrary (Id t) where
45109 arbitrary = fmap Id $ UUID.fromWords
46110 <$> arbitrary
47111 <*> arbitrary
48112 <*> arbitrary
49113 <*> arbitrary
114+#endif
50115
51−instance Binary (Id t) where
116+instance PathPiece (Id t) where
117+ fromPathPiece = coerce . UUID.fromText
118+ toPathPiece = UUID.toText . coerce
52119
53−instance PathPiece UUID.UUID where
54− fromPathPiece = UUID.fromText
55− toPathPiece = UUID.toText
120+#ifndef ghcjs_HOST_OS
56121
57−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
58132
59133-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
60134-- You are forced to explicitly specify the phantom types you are converting
61135-- via the @TypeApplications@ compiler extension.
62−coerceId :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
136+coerceId, unsafeIdTagConvert :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
63137coerceId = coerce
64138{-# INLINE coerceId #-}
139+unsafeIdTagConvert = coerce
140+{-# INLINE unsafeIdTagConvert #-}
65141
66142-- | Id corresponding to UUID nil. Useful for testing etc.
67143nilId :: forall a. Id (Ambiguous a)
@@ -70,3 +146,110 @@ nilId = Id UUID.nil
70146-- https://kcsongor.github.io/ambiguous-tags/
71147type family Ambiguous (a :: k) :: j where
72148 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 #-}