basis/hash-sets/identity/identity.factor

   1 ! Copyright (C) 2013 John Benediktsson.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: accessors hash-sets hash-sets.wrapped kernel parser\r
   4 sequences sets sets.private vocabs.loader ;\r
   5 IN: hash-sets.identity\r
   6 \r
   7 TUPLE: identity-wrapper < wrapped-key identity-hashcode ;\r
   8 \r
   9 : <identity-wrapper> ( wrapped-key -- identity-wrapper )\r
  10     dup identity-hashcode identity-wrapper boa ; inline\r
  11 \r
  12 M: identity-wrapper equal?\r
  13     over identity-wrapper?\r
  14     [ [ underlying>> ] bi@ eq? ]\r
  15     [ 2drop f ] if ; inline\r
  16 \r
  17 M: identity-wrapper hashcode* nip identity-hashcode>> ; inline\r
  18 \r
  19 TUPLE: identity-hash-set < wrapped-hash-set ;\r
  20 \r
  21 : <identity-hash-set> ( n -- ihash-set )\r
  22     <hash-set> identity-hash-set boa ; inline\r
  23 \r
  24 M: identity-hash-set wrap-key drop <identity-wrapper> ;\r
  25 \r
  26 M: identity-hash-set clone\r
  27     underlying>> clone identity-hash-set boa ; inline\r
  28 \r
  29 : >identity-hash-set ( members -- ihash-set )\r
  30     [ <identity-wrapper> ] map >hash-set identity-hash-set boa ; inline\r
  31 \r
  32 M: identity-hash-set set-like\r
  33     drop dup identity-hash-set? [ ?members >identity-hash-set ] unless ; inline\r
  34 \r
  35 SYNTAX: IHS{ \ } [ >identity-hash-set ] parse-literal ;\r
  36 \r
  37 { "hash-sets.identity" "prettyprint" } "hash-sets.identity.prettyprint" require-when\r