@@ -1,42 +1,255 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE TemplateHaskell #-}
4+{-# OPTIONS_GHC -Wno-orphans #-}
5+
16module Data.Id
2− ( Id(..)
3− , coerceId
4− ) 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
515
616import Control.DeepSeq (NFData)
7−import Data.Aeson (FromJSON, ToJSON)
17+import Control.Lens
18+import Control.Monad
19+import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
820import Data.Binary (Binary)
921import Data.Coerce (coerce)
22+import Data.Data
1023import Data.Hashable (Hashable)
11−import Data.UUID (UUID)
12−import qualified Data.UUID as UUID
13−import Database.PostgreSQL.Simple.FromField (FromField)
14−import Database.PostgreSQL.Simple.ToField (ToField)
15−import GHC.Generics (Generic)
16−import Test.QuickCheck (Arbitrary)
17−import Yesod.Core (PathPiece(..))
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
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
1848
49+#ifdef USE_FLAT
50+import Flat as F
51+#endif
52+#ifdef USE_STORE
53+import qualified Data.Store
54+#endif
1955
20−newtype Id (t :: k) = Id { unId :: UUID }
21− deriving
22− ( Eq, Ord, Generic, Read, Show, ToField, FromField, PathPiece, FromJSON
23− , ToJSON, NFData, Hashable)
56+newtype 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
69+ , FromHttpApiData, ToHttpApiData )
2470
2571type role Id nominal
2672
27−instance Binary (Id t) where
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
28106
29−instance PathPiece UUID.UUID where
30− fromPathPiece = UUID.fromText
31− toPathPiece = UUID.toText
107+#ifdef BACKEND
108+instance Arbitrary (Id t) where
109+ arbitrary = fmap Id $ UUID.fromWords
110+ <$> arbitrary
111+ <*> arbitrary
112+ <*> arbitrary
113+ <*> arbitrary
114+#endif
115+
116+instance PathPiece (Id t) where
117+ fromPathPiece = coerce . UUID.fromText
118+ toPathPiece = UUID.toText . coerce
119+
120+#ifndef ghcjs_HOST_OS
121+
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
32132
33133-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
34134-- You are forced to explicitly specify the phantom types you are converting
35135-- via the @TypeApplications@ compiler extension.
36−coerceId :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
136+coerceId, unsafeIdTagConvert :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
37137coerceId = coerce
38138{-# INLINE coerceId #-}
139+unsafeIdTagConvert = coerce
140+{-# INLINE unsafeIdTagConvert #-}
39141
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 #-}
40146-- https://kcsongor.github.io/ambiguous-tags/
41147type family Ambiguous (a :: k) :: j where
42148 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 #-}