From b168e4b50e84c4d864098404bd192baa2411562a Mon Sep 17 00:00:00 2001
From: Fumiaki Kinoshita <fumiaki.kinoshita@herp.co.jp>
Date: Mon, 14 Mar 2022 13:54:10 +0900
Subject: [PATCH] make the IsLabel instance for PI optional

---
 relational-query/relational-query.cabal       |  8 +++++++
 .../Relational/OverloadedProjection.hs        | 22 ++++++++++---------
 2 files changed, 20 insertions(+), 10 deletions(-)

diff --git a/relational-query/relational-query.cabal b/relational-query/relational-query.cabal
index 8e5ae089..ba8e6722 100644
--- a/relational-query/relational-query.cabal
+++ b/relational-query/relational-query.cabal
@@ -31,6 +31,11 @@ tested-with:           GHC == 8.8.1, GHC == 8.8.2
                      , GHC == 7.4.1, GHC == 7.4.2
 extra-source-files:  ChangeLog.md
 
+flag IsLabel
+  default: True
+  manual: True
+  description: Define an IsLabel instance for Database.Relational.Typed.Record.PI
+
 library
   exposed-modules:
                        Database.Relational.Arrow
@@ -132,6 +137,9 @@ library
     ghc-options:         -Wnoncanonical-monadfail-instances
 
   default-language:    Haskell2010
+  if flag(IsLabel)
+    ghc-options: -DISLABEL
+
 
 test-suite sqls
   build-depends:         base <5
diff --git a/relational-query/src/Database/Relational/OverloadedProjection.hs b/relational-query/src/Database/Relational/OverloadedProjection.hs
index f30545d6..8040e4a0 100644
--- a/relational-query/src/Database/Relational/OverloadedProjection.hs
+++ b/relational-query/src/Database/Relational/OverloadedProjection.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 
 #if __GLASGOW_HASKELL__ >= 800
 -- |
@@ -20,6 +21,7 @@
 --
 -- This module provides interfaces of overloaded projections.
 module Database.Relational.OverloadedProjection (
+  PiLabel(..),
   HasProjection (..),
   ) where
 
@@ -40,23 +42,23 @@ class HasProjection l a b | l a -> b where
   projection :: PiLabel l -> Pi a b
 
 #if __GLASGOW_HASKELL__ >= 802
--- | Derive 'IsLabel' instance from 'HasProjection'.
-instance HasProjection l a b => IsLabel l (Pi a b) where
-  fromLabel = projection (GetPi :: PiLabel l)
-
--- | Derive 'PI' label.
-instance (PersistableWidth a, HasProjection l a b)
-          => IsLabel l (PI c a b) where
-  fromLabel = (! projection (GetPi :: PiLabel l))
+#define FROM_LABEL fromLabel
 #else
+#define FROM_LABEL fromLabel _
+#endif
+
+instance l ~ l' => IsLabel l (PiLabel l') where -- a type equality constraint makes better type inference
+  FROM_LABEL = GetPi
+
 -- | Derive 'IsLabel' instance from 'HasProjection'.
 instance HasProjection l a b => IsLabel l (Pi a b) where
-  fromLabel _ = projection (GetPi :: PiLabel l)
+  FROM_LABEL = projection (GetPi :: PiLabel l)
 
+#if defined(ISLABEL)
 -- | Derive 'PI' label.
 instance (PersistableWidth a, HasProjection l a b)
           => IsLabel l (PI c a b) where
-  fromLabel _ = (! projection (GetPi :: PiLabel l))
+  FROM_LABEL = (! projection (GetPi :: PiLabel l))
 #endif
 #else
 module Database.Relational.OverloadedProjection () where