From 7de57ccbc6bae5c12c15c8ab57e551b733e6c3a0 Mon Sep 17 00:00:00 2001 From: Anupam Jain Date: Tue, 12 Jan 2021 01:34:12 +0530 Subject: [PATCH] Add Typeable instances for records --- spago.dhall | 4 +++- src/Data/Typeable.js | 35 ++++++++++++++++++++++++++++++++++- src/Data/Typeable.purs | 41 ++++++++++++++++++++++++++++++++++++++++- test/Main.purs | 12 +++++++++++- 4 files changed, 88 insertions(+), 4 deletions(-) diff --git a/spago.dhall b/spago.dhall index f824aad..bd6a37b 100644 --- a/spago.dhall +++ b/spago.dhall @@ -8,9 +8,11 @@ You can edit this file as you like. , "effect" , "psci-support" , "either" - , "arrays" , "exists" , "leibniz" + , "prelude" + , "tuples" + , "arrays" ] , packages = ./packages.dhall , sources = [ "src/**/*.purs", "test/**/*.purs" ] diff --git a/src/Data/Typeable.js b/src/Data/Typeable.js index c5c3f36..1802581 100644 --- a/src/Data/Typeable.js +++ b/src/Data/Typeable.js @@ -1,11 +1,13 @@ +// var _tag_id_counter = 1; + exports.typeRepDefault0 = function(t) { + // if(t.__uniqueId == undefined) t.__uniqueId = _tag_id_counter++; return t; }; exports.typeRepFromTag1 = pack('tag1'); exports.showTypeRep = function(t) { - console.log(t); return "" + t; }; @@ -53,9 +55,40 @@ exports.eqTypeRep = function(t1) { }; }; +// foreign import typeRowToTypeRep :: forall r rl. RL.RowToList r rl => TypeRow rl -> TypeRep (Record r) +exports.typeRowToTypeRep = function() { + return function(trow) { + return trow; + }; +}; + +// foreign import typeRowCons :: forall s t rs. SProxy s -> String -> TypeRep t -> TypeRow rs -> TypeRow (RL.Cons s t rs) +exports.typeRowCons = function(_) { + return function(s) { + return function(t) { + return function(r) { + return {record: r.record.concat({field:s,typ:t})}; + }; + }; + }; +}; + +// foreign import typeRowNil :: TypeRow RL.Nil +exports.typeRowNil = {record: []}; + function eqTypeRepHelper(t1,t2) { if(t1.tag0) return t1 === t2; if(t1.tag !== t2.tag) return false; + if(t1.record) { + if(!t2.record) return false; + if(t1.record.length !== t2.record.length) return false; + for(var i=0; i SomeTypeRep +wrapSomeTypeRep t = SomeTypeRep (mkExists t) + -- | Unwrap a TypeRep unwrapSomeTypeRep :: forall r. SomeTypeRep -> (forall a. TypeRep a -> r) -> r unwrapSomeTypeRep (SomeTypeRep e) f = e # runExists f @@ -114,6 +124,9 @@ foreign import proxy8FromTag9 :: forall t a. Tag9 t => Typeable a => Proxy8 (t a foreign import proxy9FromTag10 :: forall t a. Tag10 t => Typeable a => Proxy9 (t a) foreign import proxy10FromTag11 :: forall t a. Tag11 t => Typeable a => Proxy10 (t a) +instance typeableRecord :: (RL.RowToList rs ls, TypeableRecordFields ls) => Typeable (Record rs) where + typeRep = typeRowToTypeRep (typeableRecordFields (RLProxy :: _ ls)) +else instance tag0FromTag1 :: (Tag1 t, Typeable a) => Typeable (t a) where typeRep = typeRepFromTag1 else @@ -152,6 +165,32 @@ instance tag10FromTag11 :: (Tag11 t, Typeable a) => Tag10 (t a) where -- COMMON INSTANCES +-- TODO: Don't know how to use a Row instead of a RowList here +data TypeRow (r :: RL.RowList) +foreign import typeRowToTypeRep :: forall r rl. RL.RowToList 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) + +-- | A class for records where all fields have `Typeable` instances, used to +-- | implement the `Typeable` instance for records. +class TypeableRecordFields rowlist where + typeableRecordFields :: RLProxy rowlist -> TypeRow rowlist + +instance typeableRecordFieldsNil :: TypeableRecordFields RL.Nil where + typeableRecordFields _ = typeRowNil + +instance typeableRecordFieldsCons + :: ( IsSymbol key + , TypeableRecordFields rowlistTail + , Typeable focus + ) + => TypeableRecordFields (RL.Cons key focus rowlistTail) where + typeableRecordFields _ + = typeRowCons key (reflectSymbol key) (typeRep :: _ focus) tail + where + key = SProxy :: _ key + tail = typeableRecordFields (RLProxy :: _ rowlistTail) + instance taggedInt :: Tag0 Int where tag0 = proxy0 diff --git a/test/Main.purs b/test/Main.purs index 60cbe26..e6d00e9 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -10,22 +10,32 @@ foreign import clog :: forall a. a -> Effect Unit main :: Effect Unit main = do + clog (typeRep :: _ {name::String, age::Int}) + clog (eqTypeRep typeRecord (typeRep :: _ {name::String, age::Int})) clog (eqTypeRep (typeRep :: _ Person) typePerson) clog (eqTypeRep (typeRep :: _ (Array Person)) typeArrPerson) clog (eqTypeRep (typeRep :: _ (Array Person2)) typeArrPerson) clog (eqTypeRep (typeRep :: _ (Optional Int)) (typeRepFromVal (Some 1))) clog (eqTypeRep (typeRep :: _ (Optional Person)) (typeRepFromVal (Some 1))) clog (eqTypeRep (typeRep :: _ (Either Int Person)) (typeRep :: _ (Either Int Person))) - clog (typeRep :: _ (Either (Either Int Int) (Optional (Array (Person))))) + 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 :: _ 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 + +-- A data type without a typeable instance +data Break data Foo a b c = Foo instance tag3Foo :: Tag3 Foo where tag3 = proxy3