git.iko.soy/typeable/id
on master help sign in
Add new kinds of Ids and instances
c87476aDmitry Olshansky
id.cabal+7−2
compare with master
unifiedsplit
@@ -14,15 +14,18 @@ library
14 base >=4.12 && <5,
14 base >=4.12 && <5,
15 binary,
15 binary,
16 deepseq,
16 deepseq,
17− QuickCheck,
17+ flat,
18 hashable,
18 hashable,
19 http-api-data,
19 http-api-data,
20 lens,
20 lens,
21 openapi3,
21 openapi3,
22− uuid,
23 path-pieces,
22 path-pieces,
23+ text,
24+ QuickCheck,
25+ uuid,
24 if !impl(ghcjs)
26 if !impl(ghcjs)
25 build-depends:
27 build-depends:
28+ cassava,
26 postgresql-simple,
29 postgresql-simple,
27 hs-source-dirs:
30 hs-source-dirs:
28 src
31 src
@@ -31,9 +34,11 @@ library
31 default-extensions:
34 default-extensions:
32 AllowAmbiguousTypes
35 AllowAmbiguousTypes
33 DeriveGeneric
36 DeriveGeneric
37+ DerivingStrategies
34 GeneralizedNewtypeDeriving
38 GeneralizedNewtypeDeriving
35 PolyKinds
39 PolyKinds
36 RankNTypes
40 RankNTypes
37 RoleAnnotations
41 RoleAnnotations
42+ ScopedTypeVariables
38 TypeApplications
43 TypeApplications
39 TypeFamilies
44 TypeFamilies
src/Data/Id.hs+117−20
@@ -4,43 +4,62 @@
4{-# OPTIONS_GHC -Wno-orphans #-}
4{-# OPTIONS_GHC -Wno-orphans #-}
5
5
6module Data.Id
6module Data.Id
7− ( Id(..)
7+ ( Id, mkId, unId, unsafeIdTagConvert, coerceId, _Id, nilId
8− , coerceId
8+ , IntId, mkIntId, unIntId, unsafeIntIdTagConvert, coerceIntId, _IntId
9− , nilId
9+ , Name, mkName, unName, unsafeNameTagConvert, coerceName, _Name
10− , _Id
10+ )
11− ) where
11+ where
12
12
13import Control.DeepSeq (NFData)
13import Control.DeepSeq (NFData)
14import Control.Lens
14import Control.Lens
15+import Control.Monad
15import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
16import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
16import Data.Binary (Binary)
17import Data.Binary (Binary)
17import Data.Coerce (coerce)
18import Data.Coerce (coerce)
18import Data.Data
19import Data.Data
19import Data.Hashable (Hashable)
20import Data.Hashable (Hashable)
20import Data.OpenApi
21import Data.OpenApi
22+import Data.String
23+import Data.Text as T
21import Data.UUID (UUID)
24import Data.UUID (UUID)
22import qualified Data.UUID as UUID
25import qualified Data.UUID as UUID
23#ifndef ghcjs_HOST_OS
26#ifndef ghcjs_HOST_OS
24−import Database.PostgreSQL.Simple.FromField (FromField)
27+import Database.PostgreSQL.Simple.FromField as PG (FromField)
25−import Database.PostgreSQL.Simple.ToField (ToField)
28+import Database.PostgreSQL.Simple.ToField as PG (ToField)
29+import Data.Csv as Csv hiding(Name)
26#endif
30#endif
27−import GHC.Generics (Generic)
31+import Flat as F
32+import GHC.TypeLits
28import Test.QuickCheck
33import Test.QuickCheck
29import Web.HttpApiData
34import Web.HttpApiData
30import Web.PathPieces (PathPiece(..))
35import Web.PathPieces (PathPiece(..))
31
36
32newtype Id t = Id { unId :: UUID }
37newtype Id t = Id { unId :: UUID }
33− deriving
38+ deriving stock Data
34− ( Eq, Ord, Generic, Read, Show, Data
39+ deriving newtype
40+ ( Eq, Ord, Binary
35#ifndef ghcjs_HOST_OS
41#ifndef ghcjs_HOST_OS
36− , ToField, FromField
42+ , PG.ToField, PG.FromField
37#endif
43#endif
38− , PathPiece, FromJSON
39− , ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema, ToParamSchema
44+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
40− , FromHttpApiData, ToHttpApiData )
45+ , ToParamSchema, FromHttpApiData, ToHttpApiData )
41
46
42type role Id nominal
47type role Id nominal
43
48
49+makePrisms ''Id
50+
51+mkId :: forall s. UUID -> Id s
52+mkId = coerce
53+{-# INLINE mkId #-}
54+
55+instance KnownSymbol s => Show (Id s) where
56+ show (Id v) = "Id-" <> symbolVal (Proxy @s) <> "-" <> show v
57+
58+instance Flat (Id s) where
59+ encode = F.encode . UUID.toWords . coerce
60+ decode = coerce . (\(a,b,c,d) -> UUID.fromWords a b c d) <$> F.decode
61+ size = F.size . UUID.toWords . coerce
62+
44instance Arbitrary (Id t) where
63instance Arbitrary (Id t) where
45 arbitrary = fmap Id $ UUID.fromWords
64 arbitrary = fmap Id $ UUID.fromWords
46 <$> arbitrary
65 <$> arbitrary
@@ -48,20 +67,29 @@ instance Arbitrary (Id t) where
48 <*> arbitrary
67 <*> arbitrary
49 <*> arbitrary
68 <*> arbitrary
50
69
51−instance Binary (Id t) where
70+instance PathPiece (Id t) where
71+ fromPathPiece = coerce . UUID.fromText
72+ toPathPiece = UUID.toText . coerce
73+
74+#ifndef ghcjs_HOST_OS
52
75
53−instance PathPiece UUID.UUID where
76+instance Csv.FromField (Id tag) where
54− fromPathPiece = UUID.fromText
77+ parseField = parseField
55− toPathPiece = UUID.toText
78+ >=> fmap mkId . maybe (fail "invalid UUID in CSV") pure . UUID.fromText
56
79
57−makePrisms ''Id
80+instance Csv.ToField (Id tag) where
81+ toField = Csv.toField . UUID.toText . coerce
82+
83+#endif
58
84
59-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
85-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
60-- You are forced to explicitly specify the phantom types you are converting
86-- You are forced to explicitly specify the phantom types you are converting
61-- via the @TypeApplications@ compiler extension.
87-- via the @TypeApplications@ compiler extension.
62−coerceId :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
88+coerceId, unsafeIdTagConvert :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
63coerceId = coerce
89coerceId = coerce
64{-# INLINE coerceId #-}
90{-# INLINE coerceId #-}
91+unsafeIdTagConvert = coerce
92+{-# INLINE unsafeIdTagConvert #-}
65
93
66-- | Id corresponding to UUID nil. Useful for testing etc.
94-- | Id corresponding to UUID nil. Useful for testing etc.
67nilId :: forall a. Id (Ambiguous a)
95nilId :: forall a. Id (Ambiguous a)
@@ -70,3 +98,72 @@ nilId = Id UUID.nil
70-- https://kcsongor.github.io/ambiguous-tags/
98-- https://kcsongor.github.io/ambiguous-tags/
71type family Ambiguous (a :: k) :: j where
99type family Ambiguous (a :: k) :: j where
72 Ambiguous x = x
100 Ambiguous x = x
101+
102+----------------- IntId
103+newtype IntId t = IntId { unIntId :: Integer }
104+ deriving stock Data
105+ deriving newtype
106+ ( Eq, Ord, Binary
107+#ifndef ghcjs_HOST_OS
108+ , PG.ToField, PG.FromField, Csv.ToField, Csv.FromField
109+#endif
110+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
111+ , ToParamSchema, FromHttpApiData, ToHttpApiData, PathPiece, Flat, Arbitrary
112+ , Num, Integral, Real, Enum )
113+
114+type role IntId nominal
115+
116+makePrisms ''IntId
117+
118+mkIntId :: forall s. Integer -> IntId s
119+mkIntId = coerce
120+{-# INLINE mkIntId #-}
121+
122+instance KnownSymbol s => Show (IntId s) where
123+ show (IntId v) = "IntId-" <> symbolVal (Proxy @s) <> "-" <> show v
124+
125+-- | This is a more \"explicit\" 'coerce' specifically for 'IntId'.
126+-- You are forced to explicitly specify the phantom types you are converting
127+-- via the @TypeApplications@ compiler extension.
128+coerceIntId, unsafeIntIdTagConvert
129+ :: forall a b. IntId (Ambiguous a) -> IntId (Ambiguous b)
130+coerceIntId = coerce
131+{-# INLINE coerceIntId #-}
132+unsafeIntIdTagConvert = coerce
133+{-# INLINE unsafeIntIdTagConvert #-}
134+
135+----------------- Name
136+newtype Name t = Name { unName :: Text }
137+ deriving stock Data
138+ deriving newtype
139+ ( Eq, Ord, Binary
140+#ifndef ghcjs_HOST_OS
141+ , PG.ToField, PG.FromField, Csv.ToField, Csv.FromField
142+#endif
143+ , FromJSON, ToJSON, NFData, Hashable, FromJSONKey, ToJSONKey, ToSchema
144+ , ToParamSchema, FromHttpApiData, ToHttpApiData, PathPiece, Flat
145+ , IsString, Semigroup, Monoid )
146+
147+type role Name nominal
148+
149+makePrisms ''Name
150+
151+mkName :: forall s. Text -> Name s
152+mkName = coerce
153+{-# INLINE mkName #-}
154+
155+instance KnownSymbol s => Show (Name s) where
156+ show (Name v) = "Name-" <> symbolVal (Proxy @s) <> "-" <> show v
157+
158+instance Arbitrary (Name s) where
159+ arbitrary = coerce . T.pack . getPrintableString <$> arbitrary
160+
161+-- | This is a more \"explicit\" 'coerce' specifically for 'Name'.
162+-- You are forced to explicitly specify the phantom types you are converting
163+-- via the @TypeApplications@ compiler extension.
164+coerceName, unsafeNameTagConvert
165+ :: forall a b. Name (Ambiguous a) -> Name (Ambiguous b)
166+coerceName = coerce
167+{-# INLINE coerceName #-}
168+unsafeNameTagConvert = coerce
169+{-# INLINE unsafeNameTagConvert #-}
stack.yamlnew file+4
@@ -0,0 +1,4 @@
1+resolver: lts-18.18
2+
3+packages:
4+- .