@@ -1,60 +1,255 @@
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE TemplateHaskell #-}
3{-# LANGUAGE TemplateHaskell #-}
3{-# OPTIONS_GHC -Wno-orphans #-}
4{-# OPTIONS_GHC -Wno-orphans #-}
5module Data.Id
6module Data.Id
6− ( Id(..)
7+ ( Id, mkId, unId, unsafeIdTagConvert, coerceId, _Id, nilId
7− , coerceId
8+ , IntId, mkIntId, unIntId, unsafeIntIdTagConvert, coerceIntId, _IntId
8− , _Id
9+ , Name, mkName, unName, unsafeNameTagConvert, coerceName, _Name
11import Control.DeepSeq (NFData)
16import Control.DeepSeq (NFData)
12import Control.Lens
17import Control.Lens
13import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
19import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
14import Data.Binary (Binary)
20import Data.Binary (Binary)
15import Data.Coerce (coerce)
21import Data.Coerce (coerce)
16import Data.Data
22import Data.Data
17import Data.Hashable (Hashable)
23import Data.Hashable (Hashable)
18−import Data.OpenApi
24+import Data.String
19−import Data.UUID (UUID)
26+import Data.UUID.Types (UUID)
20−import qualified Data.UUID as UUID
27+import qualified Data.UUID.Types as UUID
21−import Database.PostgreSQL.Simple.FromField (FromField)
22−import Database.PostgreSQL.Simple.ToField (ToField)
23−import GHC.Generics (Generic)
28+import GHC.TypeLits
24−import Test.QuickCheck
29+import Prelude as P
30+import Text.ParserCombinators.ReadP
25import Web.HttpApiData
31import Web.HttpApiData
26import Web.PathPieces (PathPiece(..))
32import Web.PathPieces (PathPiece(..))
35+import qualified Data.UUID.V4 as UUID.V4
39+import Test.QuickCheck
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
28newtype Id t = Id { unId :: UUID }
56newtype Id t = Id { unId :: UUID }
29− deriving
57+ deriving stock Data
30− ( Eq, Ord, Generic, Read, Show, Data, ToField, FromField, PathPiece, FromJSON
62+ , PG.ToField, PG.FromField
31− , ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema, ToParamSchema
65+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey
67+ , ToSchema, ToParamSchema
32 , FromHttpApiData, ToHttpApiData )
69 , FromHttpApiData, ToHttpApiData )
34type role Id nominal
71type 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
36instance Arbitrary (Id t) where
108instance Arbitrary (Id t) where
37 arbitrary = fmap Id $ UUID.fromWords
109 arbitrary = fmap Id $ UUID.fromWords
38 <$> arbitrary
110 <$> arbitrary
39 <*> arbitrary
111 <*> arbitrary
40 <*> arbitrary
112 <*> arbitrary
41 <*> arbitrary
113 <*> arbitrary
43−instance Binary (Id t) where
116+instance PathPiece (Id t) where
117+ fromPathPiece = coerce . UUID.fromText
118+ toPathPiece = UUID.toText . coerce
45−instance PathPiece UUID.UUID where
120+#ifndef ghcjs_HOST_OS
46− fromPathPiece = UUID.fromText
47− toPathPiece = UUID.toText
49−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
127+instance Csv.ToField (Id tag) where
128+ toField = Csv.toField . UUID.toText . coerce
51-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
133-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
52-- You are forced to explicitly specify the phantom types you are converting
134-- You are forced to explicitly specify the phantom types you are converting
53-- via the @TypeApplications@ compiler extension.
135-- via the @TypeApplications@ compiler extension.
54−coerceId :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
136+coerceId, unsafeIdTagConvert :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
55coerceId = coerce
137coerceId = coerce
56{-# INLINE coerceId #-}
138{-# INLINE coerceId #-}
139+unsafeIdTagConvert = coerce
140+{-# INLINE unsafeIdTagConvert #-}
142+-- | Id corresponding to UUID nil. Useful for testing etc.
143+nilId :: forall a. Id (Ambiguous a)
58-- https://kcsongor.github.io/ambiguous-tags/
146-- https://kcsongor.github.io/ambiguous-tags/
59type family Ambiguous (a :: k) :: j where
147type family Ambiguous (a :: k) :: j where
60 Ambiguous x = x
148 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 #-}