From f3dd0c0fb13f2d21851906500d59695ca13aa266 Mon Sep 17 00:00:00 2001
From: Anupam Jain <ajnsit@gmail.com>
Date: Thu, 6 Jul 2023 20:10:22 +0530
Subject: [PATCH] Reduce dependence on the internal dictionary passing
 mechanism

Part of this work was done by @the-dr-lazy in
https://github.com/ajnsit/purescript-typeable/pull/3.

GOOD:
Now there is no more dependence on dictionaries being passed as function
arguments at runtime.

BAD:
1. However, we still depend on the dictionaries being stable at runtime.
2. We now also assume that the output of the new function `makeTag` will
never be cached.
---
 .gitignore             |   1 +
 src/Data/Typeable.js   |  31 ++++-------
 src/Data/Typeable.purs | 119 +++++++++++++++++------------------------
 test/Main.purs         |  21 ++------
 test/Person.purs       |   7 +--
 5 files changed, 70 insertions(+), 109 deletions(-)

diff --git a/.gitignore b/.gitignore
index 30efe19..0ef4a63 100644
--- a/.gitignore
+++ b/.gitignore
@@ -8,3 +8,4 @@
 /.purs*
 /.psa*
 /.spago
+.pnpm-debug.log
diff --git a/src/Data/Typeable.js b/src/Data/Typeable.js
index 0a4c8dd..772df69 100644
--- a/src/Data/Typeable.js
+++ b/src/Data/Typeable.js
@@ -1,29 +1,19 @@
-// var _tag_id_counter = 1;
-
-export function typeRepDefault0Impl(t) {
-  return t;
-}
-
-export const typeRepFromTag1Impl = pack('tagT');
 
 export function showTypeRep(t) {
   return "" + t;
 }
 
-export const proxyT = tag;
-
 // Just a JS class, instances of which can be tested for equality
-function tag() { }
+function Tag() { }
 
-export const proxyTFromTagTImpl = pack('tagT');
+export function makeTag(_) {
+  return new Tag();
+}
 
-function pack(tagName) {
-  return function(origTag) {
-    let unwrappedTag = origTag[tagName];
-    return function(typeRep) {
-      if (unwrappedTag.tag) return { tag: unwrappedTag.tag, args: unwrappedTag.args.concat(typeRep) };
-      return { tag: origTag, args: [typeRep] };
-    };
+export function tag1Impl(origTag) {
+  return function(typeRep) {
+    if (origTag instanceof Tag) return { tag: origTag, args: [typeRep] };
+    else return { tag: origTag.tag, args: origTag.args.concat(typeRep) };
   };
 };
 
@@ -52,7 +42,6 @@ export function typeRowCons(_) {
 export const typeRowNil = { record: [] };
 
 function eqTypeRepHelper(t1, t2) {
-  if (t1.tagT) return t1 === t2;
   if (t1.record) {
     if (!t2.record) return false;
     if (t1.record.length !== t2.record.length) return false;
@@ -62,8 +51,8 @@ function eqTypeRepHelper(t1, t2) {
     }
     return true;
   }
-  if (!t1.args) return false;
-  if (t1.args.length !== t2.args.length) return false;
+  if (t1 instanceof Tag) return t1 === t2;
+  if (t1.tag !== t2.tag || t1.args.length !== t2.args.length) return false;
   for (var i = 0; i < t1.args.length; i++) {
     if (!eqTypeRepHelper(t1.args[i], t2.args[i])) return false;
   }
diff --git a/src/Data/Typeable.purs b/src/Data/Typeable.purs
index 979f947..6d726d1 100644
--- a/src/Data/Typeable.purs
+++ b/src/Data/Typeable.purs
@@ -17,10 +17,11 @@ module Data.Typeable
   , unwrapSomeTypeRep
   , runSomeTypeRep
   , eqSomeTypeRep
-  , ProxyT
-  , proxyT
-  , class TagT
-  , tagT
+  , typeRepFromTag
+  , Tag
+  , makeTag
+  , class Tagged
+  , tag
   ) where
 
 import Control.Category (identity)
@@ -35,7 +36,7 @@ import Data.Newtype (unwrap)
 import Data.Ordering (Ordering)
 import Data.Show (class Show)
 import Data.Symbol (class IsSymbol, reflectSymbol)
-import Data.Unit (Unit)
+import Data.Unit (Unit, unit)
 import Prim.RowList as RL
 import Type.Proxy (Proxy(..))
 import Unsafe.Coerce (unsafeCoerce)
@@ -106,60 +107,42 @@ unwrapSomeTypeRep t f = runSomeTypeRep f t
 eqSomeTypeRep :: SomeTypeRep -> SomeTypeRep -> Boolean
 eqSomeTypeRep s1 s2 = unwrapSomeTypeRep s1 \t1 -> unwrapSomeTypeRep s2 \t2 -> eqTypeRep t1 t2
 
+-- | Every Tag can be converted to the corresponding TypeRep
+typeRepFromTag :: forall a. Tag a -> TypeRep a
+typeRepFromTag = unsafeCoerce
+
 -- MACHINERY + INSTANCES
 
--- Coerce must have a type sig, and must not be inlined else it won't get passed the dicts
-coerceTagDict :: forall a r. (TagTDict a -> r) -> (TagT a => r)
-coerceTagDict = unsafeCoerce
-
--- HACK: For https://github.com/purescript/purescript/pull/4240
-typeRepDefault0 :: forall a. TagT a => TypeRep a
-typeRepDefault0 = coerceTagDict typeRepDefault0Impl
-
--- typeRepDefaultImpl :: forall a. TagT a => TypeRep a
-foreign import typeRepDefault0Impl :: forall a. TagTDict a -> TypeRep a
-
--- HACK: For https://github.com/purescript/purescript/pull/4240
-typeRepFromTag1 :: forall a b. TagT a => Typeable b => TypeRep (a b)
-typeRepFromTag1 = coerceTagDict typeRepFromTag1Impl typeRep
-
--- typeRepFromTag1Impl :: forall a b. TagT a => Typeable b => TypeRep (a b)
-foreign import typeRepFromTag1Impl :: forall a b. TagTDict a -> TypeRep b -> TypeRep (a b)
+typeRepFromTag1 :: forall a b. Tagged a => Typeable b => TypeRep (a b)
+typeRepFromTag1 = typeRepFromTag (tag1Impl tag typeRep)
 
 foreign import showTypeRep :: forall a. TypeRep a -> String
 
--- Tagging types, this is basically the same as `Type.Proxy`
--- but we don't want to export any constructors
-data ProxyT :: forall k. k -> Type
-data ProxyT t
+-- | An Opaque Tag type
+foreign import data Tag :: forall k. k -> Type
 
-foreign import proxyT :: forall t. ProxyT t
+-- | This is the only way to create Tags
+-- | It's a function so that it can never be inlined by the compiler.
+-- | This function returns unique values that are never equal.
+foreign import makeTag :: forall t. Unit -> Tag t
 
 -- | This class should only be used to specify instances for your own datatypes to automatically get Typeable instances
--- | It's never necessary to use TagT as a constraint in order to use Typeable
-class TagT :: forall k. k -> Constraint
-class TagT a where
-  tagT :: ProxyT a
+-- | It's never necessary to use Tagged as a constraint in order to use Typeable
+class Tagged :: forall k. k -> Constraint
+class Tagged a where
+  tag :: Tag a
 
-data TagTDict :: forall k. k -> Type
-data TagTDict t
-
--- HACK: For https://github.com/purescript/purescript/pull/4240
-proxyTFromTagT :: forall t a. TagT t => Typeable a => ProxyT (t a)
-proxyTFromTagT = coerceTagDict proxyTFromTagTImpl typeRep
-
--- foreign import proxyTFromTagTImpl :: forall t a. TagT t => Typeable a => ProxyT (t a)
-foreign import proxyTFromTagTImpl :: forall t a. TagTDict t -> TypeRep a -> ProxyT (t a)
+foreign import tag1Impl :: forall t a. Tag t -> TypeRep a -> Tag (t a)
 
 instance typeableRecord :: (RL.RowToList rs ls, TypeableRecordFields ls) => Typeable (Record rs) where
   typeRep = typeRowToTypeRep (typeableRecordFields (Proxy :: _ ls))
-else instance typeableTag1 :: (TagT t, Typeable a) => Typeable (t a) where
+else instance typeableTag1 :: (Tagged t, Typeable a) => Typeable (t a) where
   typeRep = typeRepFromTag1
-else instance typeableTag0 :: TagT t => Typeable t where
-  typeRep = typeRepDefault0
+else instance typeableTag0 :: Tagged t => Typeable t where
+  typeRep = typeRepFromTag tag
 
-instance tagTFromTagT :: (TagT t, Typeable a) => TagT (t a) where
-  tagT = proxyTFromTagT
+instance tag1 :: (Tagged t, Typeable a) => Tagged (t a) where
+  tag = tag1Impl tag typeRep
 
 -- COMMON INSTANCES
 
@@ -169,8 +152,6 @@ data TypeRow r
 typeRowToTypeRep :: forall r rl. RL.RowToList r rl => TypeRow rl -> TypeRep (Record r)
 typeRowToTypeRep = typeRowToTypeRepImpl
 
--- HACK: For https://github.com/purescript/purescript/pull/4240
--- This doesn't depend on getting a reference to the dictionary so we don't need it in the FFI
 foreign import typeRowToTypeRepImpl :: forall r rl. TypeRow rl -> TypeRep (Record r)
 
 foreign import typeRowNil :: TypeRow RL.Nil
@@ -196,35 +177,35 @@ instance typeableRecordFieldsCons ::
     key = Proxy :: _ key
     tail = typeableRecordFields (Proxy :: _ rowlistTail)
 
-instance taggedInt :: TagT Int where
-  tagT = proxyT
+instance taggedInt :: Tagged Int where
+  tag = makeTag unit
 
-instance tagTBoolean :: TagT Boolean where
-  tagT = proxyT
+instance tagBoolean :: Tagged Boolean where
+  tag = makeTag unit
 
-instance tagTNumber :: TagT Number where
-  tagT = proxyT
+instance tagNumber :: Tagged Number where
+  tag = makeTag unit
 
-instance tagTChar :: TagT Char where
-  tagT = proxyT
+instance tagChar :: Tagged Char where
+  tag = makeTag unit
 
-instance tagTString :: TagT String where
-  tagT = proxyT
+instance tagString :: Tagged String where
+  tag = makeTag unit
 
-instance tagTUnit :: TagT Unit where
-  tagT = proxyT
+instance tagUnit :: Tagged Unit where
+  tag = makeTag unit
 
-instance taggedArray :: TagT Array where
-  tagT = proxyT
+instance taggedArray :: Tagged Array where
+  tag = makeTag unit
 
-instance taggedMaybe :: TagT Maybe where
-  tagT = proxyT
+instance taggedMaybe :: Tagged Maybe where
+  tag = makeTag unit
 
-instance tag2Func :: TagT (->) where
-  tagT = proxyT
+instance tag2Func :: Tagged (->) where
+  tag = makeTag unit
 
-instance tag2Either :: TagT Either where
-  tagT = proxyT
+instance tag2Either :: Tagged Either where
+  tag = makeTag unit
 
-instance tagTOrdering :: TagT Ordering where
-  tagT = proxyT
+instance tagOrdering :: Tagged Ordering where
+  tag = makeTag unit
diff --git a/test/Main.purs b/test/Main.purs
index 90a145f..6dabfba 100644
--- a/test/Main.purs
+++ b/test/Main.purs
@@ -4,7 +4,7 @@ import Prelude
 
 import Control.Monad.Error.Class (class MonadThrow)
 import Data.Either (Either)
-import Data.Typeable (class TagT, TypeRep, eqTypeRep, proxyT, typeRep, typeRepFromVal)
+import Data.Typeable (class Tagged, TypeRep, eqTypeRep, makeTag, typeRep, typeRepFromVal)
 import Effect (Effect)
 import Effect.Aff (launchAff_)
 import Effect.Exception (Error)
@@ -49,17 +49,6 @@ main = do
         assert $ eqTypeRep (typeRep :: _ (Optional Int)) (typeRepFromVal (Some 1))
         deny $ eqTypeRep (typeRep :: _ (Optional Person)) (typeRepFromVal (Some 1))
 
-  -- clog (eqTypeRep (typeRep :: _ Int) (typeRep :: _ Char))
-  -- clog (eqTypeRep (typeRep :: _ Int) (typeRep :: _ Int))
-  -- clog (typeRep :: _ Char)
-  -- clog (typeRep :: _ Int)
-
-  -- clog (typeRep :: _ Array)
-  -- clog (typeRep :: _ { name :: String, age :: Int })
-  -- clog (typeRep :: _ (Int -> Either (Either Int Int) (Optional (Array (Person)))))
-  -- clog (typeRep :: _ (Either (Either Int Int) (Optional (Array (Person)))))
-  -- clog (typeRep :: _ (Either Int Int))
-
   where
   typeRecord :: TypeRep { age :: Int, name :: String }
   typeRecord = typeRep
@@ -73,10 +62,10 @@ main = do
 
 newtype Person2 = Person2 { name :: String, location :: String }
 
-instance tagTPerson2 :: TagT Person2 where
-  tagT = proxyT
+instance tagPerson2 :: Tagged Person2 where
+  tag = makeTag unit
 
 data Optional a = None | Some a
 
-instance tagOptional :: TagT Optional where
-  tagT = proxyT
+instance tagOptional :: Tagged Optional where
+  tag = makeTag unit
diff --git a/test/Person.purs b/test/Person.purs
index 99b8412..a5c7952 100644
--- a/test/Person.purs
+++ b/test/Person.purs
@@ -1,11 +1,12 @@
 module Test.Person where
 
-import Data.Typeable (class TagT, TypeRep, proxyT, typeRep)
+import Data.Typeable (class Tagged, TypeRep, makeTag, typeRep)
+import Data.Unit (unit)
 
 newtype Person = Person { name :: String, location :: String }
 
-instance tagTPerson :: TagT Person where
-  tagT = proxyT
+instance taggedPerson :: Tagged Person where
+  tag = makeTag unit
 
 typePerson :: TypeRep Person
 typePerson = typeRep