@@ -1,255 +1,60 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE DeriveDataTypeable #-}
32{-# LANGUAGE TemplateHaskell #-}
43{-# OPTIONS_GHC -Wno-orphans #-}
54
65module Data.Id
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
6+ ( Id(..)
7+ , coerceId
8+ , _Id
9+ ) where
1510
1611import Control.DeepSeq (NFData)
1712import Control.Lens
18−import Control.Monad
1913import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
2014import Data.Binary (Binary)
2115import Data.Coerce (coerce)
2216import Data.Data
2317import Data.Hashable (Hashable)
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
31−import Web.HttpApiData
32−import Web.PathPieces (PathPiece(..))
33−
34−#ifdef USE_UUID
35−import qualified Data.UUID.V4 as UUID.V4
36−#endif
37−#ifdef BACKEND
3818import Data.OpenApi
19+import Data.UUID (UUID)
20+import qualified Data.UUID as UUID
21+import Database.PostgreSQL.Simple.FromField (FromField)
22+import Database.PostgreSQL.Simple.ToField (ToField)
23+import GHC.Generics (Generic)
3924import 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
25+import Web.HttpApiData
26+import Yesod.Core (PathPiece(..))
5527
5628newtype Id t = Id { unId :: UUID }
57− deriving stock Data
58− deriving newtype
59− ( Eq, Ord, Binary
60−#ifndef ghcjs_HOST_OS
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
68−#endif
29+ deriving
30+ ( Eq, Ord, Generic, Read, Show, Data, ToField, FromField, PathPiece, FromJSON
31+ , ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
6932 , FromHttpApiData, ToHttpApiData )
7033
7134type role Id nominal
7235
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
10836instance Arbitrary (Id t) where
10937 arbitrary = fmap Id $ UUID.fromWords
11038 <$> arbitrary
11139 <*> arbitrary
11240 <*> arbitrary
11341 <*> arbitrary
114−#endif
115−
116−instance PathPiece (Id t) where
117− fromPathPiece = coerce . UUID.fromText
118− toPathPiece = UUID.toText . coerce
11942
120−#ifndef ghcjs_HOST_OS
43+instance Binary (Id t) where
12144
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
45+instance PathPiece UUID.UUID where
46+ fromPathPiece = UUID.fromText
47+ toPathPiece = UUID.toText
12648
127−instance Csv.ToField (Id tag) where
128− toField = Csv.toField . UUID.toText . coerce
129−#endif
130−
131−#endif
49+makePrisms ''Id
13250
13351-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
13452-- You are forced to explicitly specify the phantom types you are converting
13553-- via the @TypeApplications@ compiler extension.
136−coerceId, unsafeIdTagConvert :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
54+coerceId :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
13755coerceId = coerce
13856{-# INLINE coerceId #-}
139−unsafeIdTagConvert = coerce
140−{-# INLINE unsafeIdTagConvert #-}
14157
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 #-}
14658-- https://kcsongor.github.io/ambiguous-tags/
14759type family Ambiguous (a :: k) :: j where
14860 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 #-}