Add Typeable instances for records

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" ]

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<t1.record.length;i++) {
+            if( (t1.record[i].field !== t2.record[i].field)
+                || (t1.record[i].typ !== t2.record[i].typ)) return false;
+        }
+        return true;
+    }
+    if(!t1.args) return false;
     if(t1.args.length !== t2.args.length) return false;
     for (var i=0; i<t1.args.length;i++) {
         if(!eqTypeRepHelper(t1.args[i].typeRep, t2.args[i].typeRep)) return false;

src/Data/Typeable.purs

@@ -1,11 +1,15 @@
 module Data.Typeable
 ( TypeRep
 , class Typeable
+, class TypeableRecordFields
+, typeableRecordFields
+, TypeRow
 , typeRep
 , eqT
 , eqTypeRep
 , typeRepFromVal
 , SomeTypeRep(..)
+, wrapSomeTypeRep
 , unwrapSomeTypeRep
 , Proxy0, Proxy1, Proxy2, Proxy3, Proxy4, Proxy5, Proxy6, Proxy7, Proxy8, Proxy9, Proxy10, Proxy11
 , proxy0, proxy1, proxy2, proxy3, proxy4, proxy5, proxy6, proxy7, proxy8, proxy9, proxy10, proxy11
@@ -16,13 +20,16 @@ module Data.Typeable
 import Control.Category (identity)
 import Data.Boolean (otherwise)
 import Data.Either (Either)
-import Data.Exists (Exists, runExists)
+import Data.Exists (Exists, mkExists, runExists)
 import Data.Function ((#))
 import Data.Leibniz (type (~), Leibniz)
 import Data.Maybe (Maybe(..))
 import Data.Ordering (Ordering)
 import Data.Show (class Show)
+import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
 import Data.Unit (Unit)
+import Prim.RowList as RL
+import Type.Data.RowList (RLProxy(..))
 import Unsafe.Coerce (unsafeCoerce)
 
 -- | Indexed TypeReps
@@ -51,6 +58,9 @@ typeRepFromVal _ = typeRep
 -- | Unindexed typereps
 data SomeTypeRep = SomeTypeRep (Exists TypeRep)
 
+wrapSomeTypeRep :: forall a. TypeRep a -> 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
 

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