Added id package (#4799)

* Added id package

* Updated comments

* renamed morphId to coerceId

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

id.cabal

@@ -0,0 +1,33 @@
+cabal-version: 2.4
+
+name: id
+version: 0.1.0.0
+
+library
+  exposed-modules:
+    Data.Id
+  -- other-modules:
+  -- other-extensions:
+  build-depends:
+    aeson,
+    base ^>=4.12.0.0,
+    binary,
+    deepseq,
+    hashable,
+    postgresql-simple,
+    QuickCheck,
+    uuid,
+    yesod-core,
+  hs-source-dirs:
+    src
+  default-language:
+    Haskell2010
+  default-extensions:
+    AllowAmbiguousTypes
+    DeriveGeneric
+    GeneralizedNewtypeDeriving
+    PolyKinds
+    RankNTypes
+    RoleAnnotations
+    TypeApplications
+    TypeFamilies

src/Data/Id.hs

@@ -0,0 +1,42 @@
+module Data.Id
+  ( Id(..)
+  , coerceId
+  ) where
+
+import           Control.DeepSeq (NFData)
+import           Data.Aeson (FromJSON, ToJSON)
+import           Data.Binary (Binary)
+import           Data.Coerce (coerce)
+import           Data.Hashable (Hashable)
+import           Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import           Database.PostgreSQL.Simple.FromField (FromField)
+import           Database.PostgreSQL.Simple.ToField (ToField)
+import           GHC.Generics (Generic)
+import           Test.QuickCheck (Arbitrary)
+import           Yesod.Core (PathPiece(..))
+
+
+newtype Id (t :: k) = Id { unId :: UUID }
+  deriving
+  ( Eq, Ord, Generic, Read, Show, ToField, FromField, PathPiece, FromJSON
+  , ToJSON, NFData, Hashable)
+
+type role Id nominal
+
+instance Binary (Id t) where
+
+instance PathPiece UUID.UUID where
+  fromPathPiece = UUID.fromText
+  toPathPiece = UUID.toText
+
+-- | This is a more \"explicit\" 'coerce' specifically for 'Id'.
+-- You are forced to explicitly specify the phantom types you are converting
+-- via the @TypeApplications@ compiler extension.
+coerceId :: forall a b. Id (Ambiguous a) -> Id (Ambiguous b)
+coerceId = coerce
+{-# INLINE coerceId #-}
+
+-- https://kcsongor.github.io/ambiguous-tags/
+type family Ambiguous (a :: k) :: j where
+  Ambiguous x = x