From 7a785fccb5c8a50f856c06301d06b4c68031c1be Mon Sep 17 00:00:00 2001 From: Anupam Jain Date: Tue, 4 Jul 2023 18:17:36 +0530 Subject: [PATCH] Get code compiling again Changes due to PureScript 0.15 1. Remove constraints from foreign imports. 2. Remove support for records due to the new apartness check. 3. Convert CommonJS to ESmodules Others: Format all files. TODO: Records are currently not supported because of the new apartness check in PureScript 0.15. The instance (Typeable (f a)) then partially overlaps with (Typeable (Record r)). Even though (a::Type) and (r::Row Type), that still isn't enough for the compiler to disambiguate. There is no way that I can see to specify an instance for all (f a) where f is NOT Record. --- src/Data/Dynamic.purs | 1 + src/Data/Typeable.js | 14 +++---- src/Data/Typeable.purs | 90 +++++++++++++++++++++++++++++++++--------- test/Main.js | 10 ++--- test/Main.purs | 65 +++++++++++++++++------------- 5 files changed, 121 insertions(+), 59 deletions(-) diff --git a/src/Data/Dynamic.purs b/src/Data/Dynamic.purs index d1d8565..7811d8e 100644 --- a/src/Data/Dynamic.purs +++ b/src/Data/Dynamic.purs @@ -12,6 +12,7 @@ import Data.Typeable (class Typeable, TypeRep, eqT, typeRep) data Dynamic' :: forall k. (k -> Type) -> k -> Type data Dynamic' t a = Dynamic' (TypeRep a) (t a) +data Dynamic :: forall k. (k -> Type) -> Type data Dynamic t = Dynamic (Exists (Dynamic' t)) -- | Wrap a value into a dynamic diff --git a/src/Data/Typeable.js b/src/Data/Typeable.js index 826f1fd..584937f 100644 --- a/src/Data/Typeable.js +++ b/src/Data/Typeable.js @@ -1,11 +1,11 @@ // var _tag_id_counter = 1; -export function typeRepDefault0(t) { +export function typeRepDefault0Impl(t) { // if(t.__uniqueId == undefined) t.__uniqueId = _tag_id_counter++; return t; } -export const typeRepFromTag1 = pack('tagT'); +export const typeRepFromTag1Impl = pack('tagT'); export function showTypeRep(t) { return "" + t; @@ -16,7 +16,7 @@ export const proxyT = tag; // Just a JS class, instances of which can be tested for equality function tag() { } -export const proxyTFromTagT = pack('tagT'); +export const proxyTFromTagTImpl = pack('tagT'); function pack(tagName) { return function(origTag) { @@ -34,11 +34,9 @@ export function eqTypeRep(t1) { }; } -// foreign import typeRowToTypeRep :: forall r rl. RL.RowToList r rl => TypeRow rl -> TypeRep (Record r) -export function typeRowToTypeRep() { - return function(trow) { - return trow; - }; +// foreign import typeRowToTypeRepImpl :: forall r rl. RL.RowToList r rl => TypeRow rl -> TypeRep (Record r) +export function typeRowToTypeRepImpl(trow) { + return trow; } // foreign import typeRowCons :: forall s t rs. SProxy s -> String -> TypeRep t -> TypeRow rs -> TypeRow (RL.Cons s t rs) diff --git a/src/Data/Typeable.purs b/src/Data/Typeable.purs index 64e2c67..a67ae20 100644 --- a/src/Data/Typeable.purs +++ b/src/Data/Typeable.purs @@ -15,6 +15,7 @@ module Data.Typeable , SomeTypeRep(..) , wrapSomeTypeRep , unwrapSomeTypeRep + , runSomeTypeRep , eqSomeTypeRep , ProxyT , proxyT @@ -25,7 +26,6 @@ module Data.Typeable import Control.Category (identity) import Data.Boolean (otherwise) import Data.Either (Either) -import Data.Exists (Exists, mkExists, runExists) import Data.Function ((#)) import Data.Functor (map) import Data.Identity (Identity(..)) @@ -34,10 +34,10 @@ import Data.Maybe (Maybe(..)) import Data.Newtype (unwrap) import Data.Ordering (Ordering) import Data.Show (class Show) -import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) +import Data.Symbol (class IsSymbol, reflectSymbol) import Data.Unit (Unit) import Prim.RowList as RL -import Type.Data.RowList (RLProxy(..)) +import Type.Proxy (Proxy(..)) import Unsafe.Coerce (unsafeCoerce) -- | Indexed TypeReps @@ -49,6 +49,9 @@ class Typeable :: forall k. k -> Constraint class Typeable a where typeRep :: TypeRep a +data TypeableDict :: forall k. k -> Type +data TypeableDict a + instance showTypeRepInstance :: Show (TypeRep a) where show t = showTypeRep t @@ -66,6 +69,9 @@ gcast a = m # map \f -> runLeibniz f a where m = eqT (typeRep :: _ a) (typeRep :: _ b) +-- TODO: The following gives an Error with overlapping instances +-- The instance (Typeable (f a)) partially overlaps (Typeable (Record a)), +-- which means the rest of its instance chain will not be considered. gcast1 :: forall s t a c. Typeable a => TagT c => TagT s => TagT t => c (s a) -> Maybe (c (t a)) gcast1 a = m # map \f -> runLeibniz f a where @@ -84,15 +90,23 @@ typeRepFromVal :: forall a. Typeable a => a -> TypeRep a typeRepFromVal _ = typeRep -- | Unindexed typereps -data SomeTypeRep = SomeTypeRep (Exists TypeRep) +-- | Note: Can't use the `exists` package because it doesn't gel with the polykinded TypeRep +data SomeTypeRep + +mkSomeTypeRep :: forall a. TypeRep a -> SomeTypeRep +mkSomeTypeRep = unsafeCoerce + +-- | Run a function on a TypeRep from a SomeTypeRep +runSomeTypeRep :: forall r. (forall a. TypeRep a -> r) -> SomeTypeRep -> r +runSomeTypeRep = unsafeCoerce -- | Wrap a TypeRep into a SomeTypeRep wrapSomeTypeRep :: forall a. TypeRep a -> SomeTypeRep -wrapSomeTypeRep t = SomeTypeRep (mkExists t) +wrapSomeTypeRep t = mkSomeTypeRep t -- | Extract a TypeRep from a SomeTypeRep unwrapSomeTypeRep :: forall r. SomeTypeRep -> (forall a. TypeRep a -> r) -> r -unwrapSomeTypeRep (SomeTypeRep e) f = e # runExists f +unwrapSomeTypeRep t f = runSomeTypeRep f t -- | Compare unindexed typereps eqSomeTypeRep :: SomeTypeRep -> SomeTypeRep -> Boolean @@ -100,8 +114,28 @@ eqSomeTypeRep s1 s2 = unwrapSomeTypeRep s1 \t1 -> unwrapSomeTypeRep s2 \t2 -> eq -- MACHINERY + INSTANCES -foreign import typeRepDefault0 :: forall a. TagT a => TypeRep a -foreign import typeRepFromTag1 :: forall a b. TagT a => Typeable b => TypeRep (a b) +-- HACK: For https://github.com/purescript/purescript/pull/4240 +typeRepDefault0 :: forall a. TagT a => TypeRep a +typeRepDefault0 = coerce typeRepDefault0Impl + where + -- Coerce must have a type sig, and must not be inlined else it won't get passed the dicts + coerce :: (TagTDict a -> TypeRep a) -> (TagT a => TypeRep a) + coerce = unsafeCoerce + +-- 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 = coerce typeRepFromTag1Impl + where + -- Coerce must have a type sig, and must not be inlined else it won't get passed the dicts + coerce :: (TagTDict a -> TypeableDict b -> TypeRep (a b)) -> (TagT a => Typeable b => TypeRep (a b)) + coerce = unsafeCoerce + +-- typeRepFromTag1Impl :: forall a b. TagT a => Typeable b => TypeRep (a b) +foreign import typeRepFromTag1Impl :: forall a b. TagTDict a -> TypeableDict b -> TypeRep (a b) + foreign import showTypeRep :: forall a. TypeRep a -> String -- Tagging types, this is basically the same as `Type.Proxy` @@ -115,11 +149,24 @@ class TagT :: forall k. k -> Constraint class TagT a where tagT :: ProxyT a -foreign import proxyTFromTagT :: forall t a. TagT t => Typeable a => ProxyT (t a) +data TagTDict :: forall k. k -> Type +data TagTDict t -instance typeableRecord :: (RL.RowToList rs ls, TypeableRecordFields ls) => Typeable (Record rs) where - typeRep = typeRowToTypeRep (typeableRecordFields (RLProxy :: _ ls)) -else instance typeableTag1 :: (TagT t, Typeable a) => Typeable (t a) where +-- HACK: For https://github.com/purescript/purescript/pull/4240 +proxyTFromTagT :: forall t a. TagT t => Typeable a => ProxyT (t a) +proxyTFromTagT = coerce proxyTFromTagTImpl + where + -- Coerce must have a type sig, and must not be inlined else it won't get passed the dicts + coerce :: (TagTDict t -> TypeableDict a -> ProxyT (t a)) -> (TagT t => Typeable a => ProxyT (t a)) + coerce = unsafeCoerce + +-- foreign import proxyTFromTagTImpl :: forall t a. TagT t => Typeable a => ProxyT (t a) +foreign import proxyTFromTagTImpl :: forall t a. TagTDict t -> TypeableDict a -> ProxyT (t a) + +-- instance typeableRecord :: (RL.RowToList rs ls, TypeableRecordFields ls) => Typeable (Record rs) where +-- typeRep = typeRowToTypeRep (typeableRecordFields (Proxy :: _ ls)) +instance typeableTag1 :: (TagT t, Typeable a) => Typeable (t a) where + -- else instance typeableTag1 :: (TagT t, Typeable a) => Typeable (t a) where typeRep = typeRepFromTag1 else instance typeableTag0 :: TagT t => Typeable t where typeRep = typeRepDefault0 @@ -129,19 +176,24 @@ instance tagTFromTagT :: (TagT t, Typeable a) => TagT (t a) where -- COMMON INSTANCES --- TODO: Don't know how to use a Row instead of a RowList here --- (r :: RL.RLProxy) data TypeRow :: forall k. k -> Type data TypeRow r -foreign import typeRowToTypeRep :: forall r rl. RL.RowToList r rl => TypeRow rl -> TypeRep (Record 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 -foreign import typeRowCons :: forall s t rs. SProxy s -> String -> TypeRep t -> TypeRow rs -> TypeRow (RL.Cons s t rs) +foreign import typeRowCons :: forall s t rs. Proxy s -> String -> TypeRep t -> TypeRow rs -> TypeRow (RL.Cons s t rs) -- | A class for records where all fields have `Typeable` instances, used to -- | implement the `Typeable` instance for records. +class TypeableRecordFields :: forall k. k -> Constraint class TypeableRecordFields rowlist where - typeableRecordFields :: RLProxy rowlist -> TypeRow rowlist + typeableRecordFields :: Proxy rowlist -> TypeRow rowlist instance typeableRecordFieldsNil :: TypeableRecordFields RL.Nil where typeableRecordFields _ = typeRowNil @@ -154,8 +206,8 @@ instance typeableRecordFieldsCons :: TypeableRecordFields (RL.Cons key focus rowlistTail) where typeableRecordFields _ = typeRowCons key (reflectSymbol key) (typeRep :: _ focus) tail where - key = SProxy :: _ key - tail = typeableRecordFields (RLProxy :: _ rowlistTail) + key = Proxy :: _ key + tail = typeableRecordFields (Proxy :: _ rowlistTail) instance taggedInt :: TagT Int where tagT = proxyT diff --git a/test/Main.js b/test/Main.js index b46dcf1..279593c 100644 --- a/test/Main.js +++ b/test/Main.js @@ -1,5 +1,5 @@ -exports.clog = function(x) { - return function() { - console.log(x); - }; -}; +export function clog(x) { + return function() { + console.log(x); + }; +} diff --git a/test/Main.purs b/test/Main.purs index 0297141..2b21c60 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -17,12 +17,13 @@ foreign import clog :: forall a. a -> Effect Unit assert :: forall m. MonadThrow Error m => Boolean -> m Unit assert = shouldEqual true + deny :: forall m. MonadThrow Error m => Boolean -> m Unit deny = shouldEqual false main :: Effect Unit main = do - launchAff_ $ runSpec [consoleReporter] do + launchAff_ $ runSpec [ consoleReporter ] do describe "Typeable" do it "can handle primitives" do deny $ eqTypeRep (typeRep :: _ Int) (typeRep :: _ Char) @@ -40,48 +41,58 @@ main = do assert $ eqTypeRep (typeRep :: _ (Either Int Person)) (typeRep :: _ (Either Int Person)) assert $ eqTypeRep (typeRep :: _ (Array Person)) typeArrPerson deny $ eqTypeRep (typeRep :: _ (Array Person2)) typeArrPerson - it "can handle bare records" do - assert $ eqTypeRep typeRecord (typeRep :: _ {name::String, age::Int}) + -- it "can handle bare records" do + -- assert $ eqTypeRep typeRecord (typeRep :: _ { name :: String, age :: Int }) it "can generate type reps from values" 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 (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)) - -- clog (typeRep :: _ (Foo Int Int 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)) + clog (typeRep :: _ (Foo Int Int Int)) where - typeRecord :: TypeRep {age::Int, name::String} - typeRecord = typeRep - typeArrPerson :: TypeRep (Array Person) - typeArrPerson = typeRep - typePerson :: TypeRep Person - typePerson = typeRep - -- The following should not compile since Break does not have a typeable instance - -- typeRecordBreak :: TypeRep {break::Break, name::String} - -- typeRecordBreak = typeRep + -- typeRecord :: TypeRep { age :: Int, name :: String } + -- typeRecord = typeRep + + typeArrPerson :: TypeRep (Array Person) + typeArrPerson = typeRep + + typePerson :: TypeRep Person + typePerson = typeRep + +-- The following should not compile since Break does not have a typeable instance +-- typeRecordBreak :: TypeRep {break::Break, name::String} +-- typeRecordBreak = typeRep -- A data type without a typeable instance data Break data Foo :: forall k1 k2 k3. k1 -> k2 -> k3 -> Type data Foo a b c = Foo -instance tagFoo :: TagT Foo where tagT = proxyT + +instance tagFoo :: TagT Foo where + tagT = proxyT newtype Person = Person { name :: String, location :: String } -instance tagTPerson :: TagT Person where tagT = proxyT + +instance tagTPerson :: TagT Person where + tagT = proxyT newtype Person2 = Person2 { name :: String, location :: String } -instance tagTPerson2 :: TagT Person2 where tagT = proxyT + +instance tagTPerson2 :: TagT Person2 where + tagT = proxyT data Optional a = None | Some a -instance tagOptional :: TagT Optional where tagT = proxyT + +instance tagOptional :: TagT Optional where + tagT = proxyT