@@ -4,140 +4,64 @@
4{-# OPTIONS_GHC -Wno-orphans #-}
4{-# OPTIONS_GHC -Wno-orphans #-}
6module Data.Id
6module Data.Id
7− ( Id, mkId, unId, unsafeIdTagConvert, coerceId, _Id, nilId
7+ ( Id(..)
8− , IntId, mkIntId, unIntId, unsafeIntIdTagConvert, coerceIntId, _IntId
8+ , coerceId
9− , Name, mkName, unName, unsafeNameTagConvert, coerceName, _Name
9+ , nilId
10−#ifdef USE_UUID
10+ , _Id
16import Control.DeepSeq (NFData)
13import Control.DeepSeq (NFData)
17import Control.Lens
14import Control.Lens
19import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
15import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
20import Data.Binary (Binary)
16import Data.Binary (Binary)
21import Data.Coerce (coerce)
17import Data.Coerce (coerce)
22import Data.Data
18import Data.Data
23import Data.Hashable (Hashable)
19import Data.Hashable (Hashable)
26−import Data.UUID.Types (UUID)
27−import qualified Data.UUID.Types as UUID
30−import Text.ParserCombinators.ReadP
31−import Web.HttpApiData
32−import Web.PathPieces (PathPiece(..))
35−import qualified Data.UUID.V4 as UUID.V4
38import Data.OpenApi
20import Data.OpenApi
39−import Test.QuickCheck
21+import Data.UUID (UUID)
41−import Data.Csv as Csv hiding(Name)
44−import Database.PostgreSQL.Simple.FromField as PG (FromField)
45−import Database.PostgreSQL.Simple.ToField as PG (ToField)
53−import qualified Data.Store
22+import qualified Data.UUID as UUID
24+import Database.PostgreSQL.Simple.FromField (FromField)
25+import Database.PostgreSQL.Simple.ToField (ToField)
27+import GHC.Generics (Generic)
28+import Test.QuickCheck
29+import Web.HttpApiData
30+import Web.PathPieces (PathPiece(..))
56newtype Id t = Id { unId :: UUID }
32newtype Id t = Id { unId :: UUID }
57− deriving stock Data
33+ deriving
58− deriving newtype
34+ ( Eq, Ord, Generic, Read, Show, Data
60#ifndef ghcjs_HOST_OS
35#ifndef ghcjs_HOST_OS
62− , PG.ToField, PG.FromField
36+ , ToField, FromField
65− , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey
67− , ToSchema, ToParamSchema
38+ , PathPiece, FromJSON
39+ , ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema, ToParamSchema
69 , FromHttpApiData, ToHttpApiData )
40 , FromHttpApiData, ToHttpApiData )
71type role Id nominal
42type role Id nominal
75−mkId :: forall s. UUID -> Id s
80−randomId :: forall s. IO (Id s)
81−randomId = coerce <$> UUID.V4.nextRandom
82−{-# INLINE randomId #-}
85−instance KnownSymbol s => Show (Id s) where
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
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
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
108instance Arbitrary (Id t) where
44instance Arbitrary (Id t) where
109 arbitrary = fmap Id $ UUID.fromWords
45 arbitrary = fmap Id $ UUID.fromWords
110 <$> arbitrary
46 <$> arbitrary
111 <*> arbitrary
47 <*> arbitrary
112 <*> arbitrary
48 <*> arbitrary
113 <*> arbitrary
49 <*> arbitrary
116−instance PathPiece (Id t) where
117− fromPathPiece = coerce . UUID.fromText
118− toPathPiece = UUID.toText . coerce
120−#ifndef ghcjs_HOST_OS
123−instance Csv.FromField (Id tag) where
51+instance Binary (Id t) where
124− parseField = parseField
125− >=> fmap mkId . maybe (fail "invalid UUID in CSV") pure . UUID.fromText
127−instance Csv.ToField (Id tag) where
53+instance PathPiece UUID.UUID where
128− toField = Csv.toField . UUID.toText . coerce
54+ fromPathPiece = UUID.fromText
129−#endif
55+ toPathPiece = UUID.toText
131−#endif
57+makePrisms ''Id
133-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
59-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
134-- You are forced to explicitly specify the phantom types you are converting
60-- You are forced to explicitly specify the phantom types you are converting
135-- via the @TypeApplications@ compiler extension.
61-- via the @TypeApplications@ compiler extension.
136−coerceId, unsafeIdTagConvert :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
62+coerceId :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
137coerceId = coerce
63coerceId = coerce
138{-# INLINE coerceId #-}
64{-# INLINE coerceId #-}
139−unsafeIdTagConvert = coerce
140−{-# INLINE unsafeIdTagConvert #-}
142-- | Id corresponding to UUID nil. Useful for testing etc.
66-- | Id corresponding to UUID nil. Useful for testing etc.
143nilId :: forall a. Id (Ambiguous a)
67nilId :: forall a. Id (Ambiguous a)
@@ -146,110 +70,3 @@ nilId = Id UUID.nil
146-- https://kcsongor.github.io/ambiguous-tags/
70-- https://kcsongor.github.io/ambiguous-tags/
147type family Ambiguous (a :: k) :: j where
71type family Ambiguous (a :: k) :: j where
148 Ambiguous x = x
72 Ambiguous x = x
150−----------------- IntId
151−newtype IntId t = IntId { unIntId :: Integer }
155−#ifndef ghcjs_HOST_OS
157− , PG.ToField, PG.FromField
160− , Csv.ToField, Csv.FromField
170− , ToSchema, ToParamSchema, Arbitrary
172− , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, FromHttpApiData
173− , ToHttpApiData, PathPiece, Num, Integral, Real, Enum )
175−type role IntId nominal
179−mkIntId :: forall s. Integer -> IntId s
181−{-# INLINE mkIntId #-}
183−instance KnownSymbol s => Show (IntId s) where
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
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)
197−{-# INLINE coerceIntId #-}
198−unsafeIntIdTagConvert = coerce
199−{-# INLINE unsafeIntIdTagConvert #-}
201−----------------- Name
202−newtype Name t = Name { unName :: Text }
206−#ifndef ghcjs_HOST_OS
208− , PG.ToField, PG.FromField
211− , Csv.ToField, Csv.FromField
221− , ToSchema, ToParamSchema
223− , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, FromHttpApiData
224− , ToHttpApiData, PathPiece, IsString, Semigroup, Monoid )
226−type role Name nominal
230−mkName :: forall s. Text -> Name s
232−{-# INLINE mkName #-}
234−instance KnownSymbol s => Show (Name s) where
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
243−instance Arbitrary (Name s) where
244− arbitrary = coerce . T.pack . getPrintableString <$> arbitrary
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)
253−{-# INLINE coerceName #-}
254−unsafeNameTagConvert = coerce
255−{-# INLINE unsafeNameTagConvert #-}