lum/purescript-typeable
3
0
Fork 0
forked from github/purescript-typeable
Code Pull Requests Activity

Get code compiling again

Browse Source 
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.
This commit is contained in:
Anupam Jain 2023-07-04 18:17:36 +05:30
parent 696d538d05
commit 7a785fccb5
5 changed files with 121 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/Data/Dynamic.purs
View File

@ -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

14
src/Data/Typeable.js
View File

@ -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)

90
src/Data/Typeable.purs
View File

@ -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

10
test/Main.js
View File

@ -1,5 +1,5 @@
exports.clog = function(x) {
return function() {
console.log(x);
};
};
export function clog(x) {
return function() {
console.log(x);
};
}

65
test/Main.purs
View File

@ -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