git.iko.soy/typeable/id
on rel8able help sign in
typeable/id/src/Data/Id.hs
267 lines 7.0 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE TemplateHaskell #-}
4{-# OPTIONS_GHC -Wno-orphans #-}
6module Data.Id
7 ( Id, mkId, unId, randomId, unsafeIdTagConvert, coerceId, nilId
8 , IntId, mkIntId, unIntId, unsafeIntIdTagConvert, coerceIntId
9 , Name, mkName, unName, unsafeNameTagConvert, coerceName
10#ifdef USE_LENS
11 , _Id, _IntId, _Name
12#endif
13 )
14 where
16import Control.DeepSeq (NFData)
17#ifdef USE_LENS
18import Control.Lens
19#endif
20import Control.Monad
21import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
22import Data.Binary (Binary)
23import Data.Coerce (coerce)
24import Data.Data
25import Data.Hashable (Hashable)
26import Data.Int (Int64)
27#ifdef USE_OPENAPI
28import Data.OpenApi
29#endif
30import Data.String
31import Data.Text as T
32import Data.UUID (UUID)
33import qualified Data.UUID as UUID
34import qualified Data.UUID.V4 as UUID.V4
35#ifndef ghcjs_HOST_OS
36#ifdef USE_CASSAVA
37import Data.Csv as Csv hiding(Name)
38#endif
39#ifdef USE_POSTGRES
40import Database.PostgreSQL.Simple.FromField as PG (FromField)
41import Database.PostgreSQL.Simple.ToField as PG (ToField)
42#endif
43#endif
44import GHC.TypeLits
45import Test.QuickCheck
46import Text.ParserCombinators.ReadP
47import Web.HttpApiData
48import Web.PathPieces (PathPiece(..))
49#ifdef USE_FLAT
50import Flat as F
51#endif
52#ifdef USE_STORE
53import qualified Data.Store
54#endif
55#ifdef USE_REL8
56import Rel8 (DBType(..), DBEq(..))
57#endif
59newtype Id t = Id { unId :: UUID }
60 deriving stock Data
61 deriving newtype
62 ( Eq, Ord, Binary
63#ifndef ghcjs_HOST_OS
64#ifdef USE_POSTGRES
65 , PG.ToField, PG.FromField
66#endif
67#ifdef USE_REL8
68 , DBType, DBEq
69#endif
70#endif
71 , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey
72#ifdef USE_OPENAPI
73 , ToSchema, ToParamSchema
74#endif
75 , FromHttpApiData, ToHttpApiData )
77type role Id nominal
79mkId :: forall s. UUID -> Id s
80mkId = coerce
81{-# INLINE mkId #-}
83randomId :: forall s. IO (Id s)
84randomId = coerce <$> UUID.V4.nextRandom
85{-# INLINE randomId #-}
87instance KnownSymbol s => Show (Id s) where
88 show (Id v) = "Id-" <> symbolVal (Proxy @s) <> "-" <> show v
90instance KnownSymbol s => Read (Id s) where
91 readsPrec _ = readP_to_S $ do
92 _ <- string ("Id-" <> symbolVal (Proxy @s) <> "-")
93 mkId <$> readS_to_P reads
95#ifdef USE_FLAT
96instance Flat (Id s) where
97 encode = F.encode . UUID.toWords . coerce
98 decode = coerce . (\(a,b,c,d) -> UUID.fromWords a b c d) <$> F.decode
99 size = F.size . UUID.toWords . coerce
100#endif
102#ifdef USE_STORE
103instance Data.Store.Store (Id s) where
104 poke = Data.Store.poke . UUID.toWords . coerce
105 peek = coerce . (\(a,b,c,d) -> UUID.fromWords a b c d) <$> Data.Store.peek
106 size = Data.Store.ConstSize 16
107#endif
109instance Arbitrary (Id t) where
110 arbitrary = fmap Id $ UUID.fromWords
111 <$> arbitrary
112 <*> arbitrary
113 <*> arbitrary
114 <*> arbitrary
116instance PathPiece (Id t) where
117 fromPathPiece = coerce . UUID.fromText
118 toPathPiece = UUID.toText . coerce
120#ifndef ghcjs_HOST_OS
122#ifdef USE_CASSAVA
123instance Csv.FromField (Id tag) where
124 parseField = parseField
125 >=> fmap mkId . maybe (fail "invalid UUID in CSV") pure . UUID.fromText
127instance Csv.ToField (Id tag) where
128 toField = Csv.toField . UUID.toText . coerce
129#endif
131#endif
133-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
134-- You are forced to explicitly specify the phantom types you are converting
135-- via the @TypeApplications@ compiler extension.
136coerceId, unsafeIdTagConvert :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
137coerceId = coerce
138{-# INLINE coerceId #-}
139unsafeIdTagConvert = coerce
140{-# INLINE unsafeIdTagConvert #-}
142-- | Id corresponding to UUID nil. Useful for testing etc.
143nilId :: forall a. Id (Ambiguous a)
144nilId = Id UUID.nil
145{-# INLINE nilId #-}
146-- https://kcsongor.github.io/ambiguous-tags/
147type family Ambiguous (a :: k) :: j where
148 Ambiguous x = x
150----------------- IntId
151newtype IntId t = IntId Int64
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#ifdef USE_FLAT
163 , Flat
164#endif
165#ifdef USE_STORE
166 , Data.Store.Store
167#endif
168#ifdef USE_REL8
169 , DBType, DBEq
170#endif
171#endif
172 , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey
173#ifdef USE_OPENAPI
174 , ToSchema, ToParamSchema
175#endif
176 , FromHttpApiData, ToHttpApiData, PathPiece, Arbitrary
177 , Num, Integral, Real, Enum )
179type role IntId nominal
181mkIntId :: forall s. Integer -> IntId s
182mkIntId = fromInteger
183{-# INLINE mkIntId #-}
185unIntId :: IntId s -> Integer
186unIntId (IntId i) = fromIntegral i
187{-# INLINE unIntId #-}
189instance KnownSymbol s => Show (IntId s) where
190 show (IntId v) = "IntId-" <> symbolVal (Proxy @s) <> "-" <> show v
192instance KnownSymbol s => Read (IntId s) where
193 readsPrec _ = readP_to_S $ do
194 _ <- string ("IntId-" <> symbolVal (Proxy @s) <> "-")
195 mkIntId <$> readS_to_P reads
197-- | This is a more \"explicit\" 'coerce' specifically for 'IntId'.
198-- You are forced to explicitly specify the phantom types you are converting
199-- via the @TypeApplications@ compiler extension.
200coerceIntId, unsafeIntIdTagConvert
201 :: forall a b. IntId (Ambiguous a) -> IntId (Ambiguous b)
202coerceIntId = coerce
203{-# INLINE coerceIntId #-}
204unsafeIntIdTagConvert = coerce
205{-# INLINE unsafeIntIdTagConvert #-}
207----------------- Name
208newtype Name t = Name { unName :: Text }
209 deriving stock Data
210 deriving newtype
211 ( Eq, Ord, Binary
212#ifndef ghcjs_HOST_OS
213#ifdef USE_POSTGRES
214 , PG.ToField, PG.FromField
215#endif
216#ifdef USE_CASSAVA
217 , Csv.ToField, Csv.FromField
218#endif
219#ifdef USE_FLAT
220 , Flat
221#endif
222#ifdef USE_STORE
223 , Data.Store.Store
224#endif
225#ifdef USE_REL8
226 , DBType, DBEq
227#endif
228#endif
229 , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey
230#ifdef USE_OPENAPI
231 , ToSchema, ToParamSchema
232#endif
233 , FromHttpApiData, ToHttpApiData, PathPiece
234 , IsString, Semigroup, Monoid )
236type role Name nominal
238mkName :: forall s. Text -> Name s
239mkName = coerce
240{-# INLINE mkName #-}
242instance KnownSymbol s => Show (Name s) where
243 show (Name v) = "Name-" <> symbolVal (Proxy @s) <> "-" <> show v
245instance KnownSymbol s => Read (Name s) where
246 readsPrec _ = readP_to_S $ do
247 _ <- string ("Name-" <> symbolVal (Proxy @s) <> "-")
248 mkName <$> readS_to_P reads
250instance Arbitrary (Name s) where
251 arbitrary = coerce . T.pack . getPrintableString <$> arbitrary
253-- | This is a more \"explicit\" 'coerce' specifically for 'Name'.
254-- You are forced to explicitly specify the phantom types you are converting
255-- via the @TypeApplications@ compiler extension.
256coerceName, unsafeNameTagConvert
257 :: forall a b. Name (Ambiguous a) -> Name (Ambiguous b)
258coerceName = coerce
259{-# INLINE coerceName #-}
260unsafeNameTagConvert = coerce
261{-# INLINE unsafeNameTagConvert #-}
263#ifdef USE_LENS
264makePrisms ''Id
265makePrisms ''IntId
266makePrisms ''Name
267#endif