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

Format purescript. Convert CommonJS to ESmodule.

Browse Source
This commit is contained in:
Anupam Jain 2023-07-04 17:54:05 +05:30
parent eb0b5b7a61
commit 696d538d05
4 changed files with 166 additions and 165 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

152
src/Data/Data.purs
View File

@ -36,38 +36,42 @@ mkM f = fromMaybe pure (cast f)
-- So we manually reify the dictionary into the DataDict datatype
-- Not using wrapped records here because Purescript can't handle constraints inside records
newtype DataDict a = DataDict
(forall c. (forall d b. Data d => c (d -> b) -> d -> c b)
-- ^ defines how nonempty constructor applications are
-- folded. It takes the folded tail of the constructor
-- application and its head, i.e., an immediate subterm,
-- and combines them in some way.
-> (forall g. g -> c g)
-- ^ defines how the empty constructor application is
-- folded, like the neutral \/ start element for list
-- folding.
-> a
-- ^ structure to be folded.
-> c a
-- ^ result, with a type defined in terms of @a@, but
-- variability is achieved by means of type constructor
-- @c@ for the construction of the actual result type.
( forall c
. (forall d b. Data d => c (d -> b) -> d -> c b)
-- ^ defines how nonempty constructor applications are
-- folded. It takes the folded tail of the constructor
-- application and its head, i.e., an immediate subterm,
-- and combines them in some way.
-> (forall g. g -> c g)
-- ^ defines how the empty constructor application is
-- folded, like the neutral \/ start element for list
-- folding.
-> a
-- ^ structure to be folded.
-> c a
-- ^ result, with a type defined in terms of @a@, but
-- variability is achieved by means of type constructor
-- @c@ for the construction of the actual result type.
)
gfoldl :: forall a c. Data a => (forall d b. Data d => c (d -> b) -> d -> c b)
-- ^ defines how nonempty constructor applications are
-- folded. It takes the folded tail of the constructor
-- application and its head, i.e., an immediate subterm,
-- and combines them in some way.
-> (forall g. g -> c g)
-- ^ defines how the empty constructor application is
-- folded, like the neutral \/ start element for list
-- folding.
-> a
-- ^ structure to be folded.
-> c a
-- ^ result, with a type defined in terms of @a@, but
-- variability is achieved by means of type constructor
-- @c@ for the construction of the actual result type.
gfoldl
:: forall a c
. Data a
=> (forall d b. Data d => c (d -> b) -> d -> c b)
-- ^ defines how nonempty constructor applications are
-- folded. It takes the folded tail of the constructor
-- application and its head, i.e., an immediate subterm,
-- and combines them in some way.
-> (forall g. g -> c g)
-- ^ defines how the empty constructor application is
-- folded, like the neutral \/ start element for list
-- folding.
-> a
-- ^ structure to be folded.
-> c a
-- ^ result, with a type defined in terms of @a@, but
-- variability is achieved by means of type constructor
-- @c@ for the construction of the actual result type.
gfoldl = let DataDict f = dataDict in f
class Typeable a <= Data a where
@ -86,26 +90,25 @@ gmapT :: forall a. Data a => (forall b. Data b => b -> b) -> a -> a
--
gmapT f x0 = unwrap (gfoldl k Identity x0)
where
k :: forall d b. Data d => Identity (d->b) -> d -> Identity b
k (Identity c) x = Identity (c (f x))
k :: forall d b. Data d => Identity (d -> b) -> d -> Identity b
k (Identity c) x = Identity (c (f x))
-- | A generic query with a left-associative binary operator
gmapQl :: forall a r r'. Data a => (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
gmapQl o r f = unwrap <<< gfoldl k z
where
k :: forall d b. Data d => Const r (d->b) -> d -> Const r b
k c x = Const $ (unwrap c) `o` f x
z :: forall g. g -> Const r g
z _ = Const r
k :: forall d b. Data d => Const r (d -> b) -> d -> Const r b
k c x = Const $ (unwrap c) `o` f x
z :: forall g. g -> Const r g
z _ = Const r
-- | A generic query with a right-associative binary operator
gmapQr :: forall a r r'. Data a => (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
gmapQr o r0 f x0 = unQr (gfoldl k (const (Qr identity)) x0) r0
where
k :: forall d b. Data d => Qr r (d->b) -> d -> Qr r b
k (Qr c) x = Qr (\r -> c (f x `o` r))
k :: forall d b. Data d => Qr r (d -> b) -> d -> Qr r b
k (Qr c) x = Qr (\r -> c (f x `o` r))
-- | A generic query that processes the immediate subterms and returns a list
-- of results. The list is given in the same order as originally specified
@ -113,18 +116,18 @@ gmapQr o r0 f x0 = unQr (gfoldl k (const (Qr identity)) x0) r0
gmapQ :: forall a u. Data a => (forall d. Data d => d -> u) -> a -> Array u
gmapQ f = gmapQr (A.cons) [] f
-- | A generic query that processes one child by index (zero-based)
gmapQi :: forall u a. Data a => Int -> (forall d. Data d => d -> u) -> a -> u
gmapQi i f x = case gfoldl k z x of Qi _ q -> case q of
Nothing -> unsafeCoerce "UNEXPECTED NOTHING"
Just q' -> q'
gmapQi i f x = case gfoldl k z x of
Qi _ q -> case q of
Nothing -> unsafeCoerce "UNEXPECTED NOTHING"
Just q' -> q'
where
k :: forall d b. Data d => Qi u (d -> b) -> d -> Qi u b
k (Qi i' q) a = Qi (i'+1) (if i==i' then Just (f a) else q)
z :: forall g q. g -> Qi q g
z _ = Qi 0 Nothing
k :: forall d b. Data d => Qi u (d -> b) -> d -> Qi u b
k (Qi i' q) a = Qi (i' + 1) (if i == i' then Just (f a) else q)
z :: forall g q. g -> Qi q g
z _ = Qi 0 Nothing
-- | A generic monadic transformation that maps over the immediate subterms
--
@ -139,11 +142,11 @@ gmapM :: forall m a. Data a => Monad m => (forall d. Data d => d -> m d) -> a ->
--
gmapM f = gfoldl k pure
where
k :: forall b d. Data d => m (d -> b) -> d -> m b
k c x = do c' <- c
x' <- f x
pure (c' x')
k :: forall b d. Data d => m (d -> b) -> d -> m b
k c x = do
c' <- c
x' <- f x
pure (c' x')
-- | Transformation of at least one immediate subterm does not fail
gmapMp :: forall m a. Data a => MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a
@ -157,16 +160,17 @@ this end, we couple the monadic computation with a Boolean.
-}
gmapMp f x = unMp (gfoldl k z x) >>= \(Tuple x' b) ->
if b then pure x' else empty
if b then pure x' else empty
where
z :: forall g. g -> Mp m g
z g = Mp (pure (Tuple g false))
k :: forall d b. Data d => Mp m (d -> b) -> d -> Mp m b
k (Mp c) y
= Mp ( c >>= \(Tuple h b) ->
(f y >>= \y' -> pure (Tuple (h y') true))
<|> pure (Tuple (h y) b)
)
z :: forall g. g -> Mp m g
z g = Mp (pure (Tuple g false))
k :: forall d b. Data d => Mp m (d -> b) -> d -> Mp m b
k (Mp c) y = Mp
( c >>= \(Tuple h b) ->
(f y >>= \y' -> pure (Tuple (h y') true))
<|> pure (Tuple (h y) b)
)
-- | Transformation of one immediate subterm with success
gmapMo :: forall m a. Data a => MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a
@ -182,25 +186,23 @@ was transformed successfully.
-}
gmapMo f x = unMp (gfoldl k z x) >>= \(Tuple x' b) ->
if b then pure x' else empty
if b then pure x' else empty
where
z :: forall g. g -> Mp m g
z g = Mp (pure (Tuple g false))
k :: forall d b. Data d => Mp m (d -> b) -> d -> Mp m b
k (Mp c) y
= Mp ( c >>= \(Tuple h b) -> if b
then pure (Tuple (h y) b)
else (f y >>= \y' -> pure (Tuple (h y') true))
<|> pure (Tuple (h y) b)
)
z :: forall g. g -> Mp m g
z g = Mp (pure (Tuple g false))
k :: forall d b. Data d => Mp m (d -> b) -> d -> Mp m b
k (Mp c) y = Mp
( c >>= \(Tuple h b) ->
if b then pure (Tuple (h y) b)
else (f y >>= \y' -> pure (Tuple (h y') true))
<|> pure (Tuple (h y) b)
)
-- | Type constructor for adding counters to queries
data Qi :: forall k. Type -> k -> Type
data Qi q a = Qi Int (Maybe q)
-- | The type constructor used in definition of gmapQr
newtype Qr :: forall k. Type -> k -> Type
newtype Qr r a = Qr (r -> r)
@ -214,7 +216,6 @@ newtype Mp m x = Mp (m (Tuple x Boolean))
unMp :: forall m x. Mp m x -> m (Tuple x Boolean)
unMp (Mp f) = f
-- | Left-associative fold operation for constructor applications.
--
-- The type of 'gfoldl' is a headache, but operationally it is a simple
@ -224,7 +225,6 @@ unMp (Mp f) = f
-- suitable for abstract datatypes with no substructures.
-- gfoldl
-- TODO: Why do we need `TagT` here? Instead of `Typeable`.
instance dataArray :: (TagT a, Data a) => Data (Array a) where
dataDict = DataDict \k z arr -> case A.uncons arr of

1
src/Data/Dynamic.purs
View File

@ -11,6 +11,7 @@ import Data.Typeable (class Typeable, TypeRep, eqT, typeRep)
-- | and forgets the type of `a`
data Dynamic' :: forall k. (k -> Type) -> k -> Type
data Dynamic' t a = Dynamic' (TypeRep a) (t a)
data Dynamic t = Dynamic (Exists (Dynamic' t))
-- | Wrap a value into a dynamic

105
src/Data/Typeable.js
View File

@ -1,76 +1,75 @@
// var _tag_id_counter = 1;
exports.typeRepDefault0 = function(t) {
// if(t.__uniqueId == undefined) t.__uniqueId = _tag_id_counter++;
return t;
};
export function typeRepDefault0(t) {
// if(t.__uniqueId == undefined) t.__uniqueId = _tag_id_counter++;
return t;
}
exports.typeRepFromTag1 = pack('tagT');
export const typeRepFromTag1 = pack('tagT');
exports.showTypeRep = function(t) {
return "" + t;
};
export function showTypeRep(t) {
return "" + t;
}
exports.proxyT = tag;
export const proxyT = tag;
// Just a JS class, instances of which can be tested for equality
function tag() {}
function tag() { }
exports.proxyTFromTagT = pack('tagT');
export const proxyTFromTagT = pack('tagT');
function pack(tagName) {
return function(origTag) {
let unwrappedTag = origTag[tagName];
return function(dict) {
if(unwrappedTag.tag) return {tag:unwrappedTag.tag, args:unwrappedTag.args.concat(dict)};
return {tag: origTag, args: [dict]};
};
return function(origTag) {
let unwrappedTag = origTag[tagName];
return function(dict) {
if (unwrappedTag.tag) return { tag: unwrappedTag.tag, args: unwrappedTag.args.concat(dict) };
return { tag: origTag, args: [dict] };
};
};
};
exports.eqTypeRep = function(t1) {
return function(t2) {
return eqTypeRepHelper(t1,t2);
};
};
export function eqTypeRep(t1) {
return function(t2) {
return eqTypeRepHelper(t1, t2);
};
}
// foreign import typeRowToTypeRep :: forall r rl. RL.RowToList r rl => TypeRow rl -> TypeRep (Record r)
exports.typeRowToTypeRep = function() {
return function(trow) {
return trow;
};
};
export function typeRowToTypeRep() {
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})};
};
};
export function typeRowCons(_) {
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: []};
export const typeRowNil = { record: [] };
function eqTypeRepHelper(t1,t2) {
if(t1.tagT) 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)
|| !(eqTypeRepHelper(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;
function eqTypeRepHelper(t1, t2) {
if (t1.tagT) 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)
|| !(eqTypeRepHelper(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;
}
return true;
}

73
src/Data/Typeable.purs
View File

@ -1,24 +1,26 @@
module Data.Typeable
( TypeRep
, class Typeable
, class TypeableRecordFields
, typeableRecordFields
, TypeRow
, typeRep
, eqT
, eqTypeRep
, cast
, gcast
, gcast1
, gcast2
, typeRepFromVal
, SomeTypeRep(..)
, wrapSomeTypeRep
, unwrapSomeTypeRep
, eqSomeTypeRep
, ProxyT, proxyT
, class TagT, tagT
) where
( TypeRep
, class Typeable
, class TypeableRecordFields
, typeableRecordFields
, TypeRow
, typeRep
, eqT
, eqTypeRep
, cast
, gcast
, gcast1
, gcast2
, typeRepFromVal
, SomeTypeRep(..)
, wrapSomeTypeRep
, unwrapSomeTypeRep
, eqSomeTypeRep
, ProxyT
, proxyT
, class TagT
, tagT
) where
import Control.Category (identity)
import Data.Boolean (otherwise)
@ -107,20 +109,19 @@ foreign import showTypeRep :: forall a. TypeRep a -> String
data ProxyT :: forall k. k -> Type
data ProxyT t
foreign import proxyT :: forall t. ProxyT t
foreign import proxyT :: forall t. ProxyT t
class TagT :: forall k. k -> Constraint
class TagT a where tagT :: ProxyT a
class TagT a where
tagT :: ProxyT a
foreign import proxyTFromTagT :: forall t a. TagT t => Typeable a => ProxyT (t a)
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
else instance typeableTag1 :: (TagT t, Typeable a) => Typeable (t a) where
typeRep = typeRepFromTag1
else
instance typeableTag0 :: TagT t => Typeable t where
else instance typeableTag0 :: TagT t => Typeable t where
typeRep = typeRepDefault0
instance tagTFromTagT :: (TagT t, Typeable a) => TagT (t a) where
@ -132,6 +133,7 @@ instance tagTFromTagT :: (TagT t, Typeable a) => TagT (t a) where
-- (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)
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)
@ -144,17 +146,16 @@ class TypeableRecordFields rowlist where
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
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)
key = SProxy :: _ key
tail = typeableRecordFields (RLProxy :: _ rowlistTail)
instance taggedInt :: TagT Int where
tagT = proxyT