Generics/gCons.icl

   1 implementation module Generics.gCons
   2
   3 /*
   4         Pieter Koopman 2015
   5         pieter@cs.ru.nl
   6         Radboud University, Nijmegen, The Netherlands
   7         ARDSL project
   8 */
   9
  10 import StdEnv, StdGeneric, GenBimap, _SystemStrictLists
  11 import Data.Functor
  12 import Data.List
  13 import Data.Maybe
  14
  15 consByName :: String -> Maybe a | conses{|*|}, consName{|*|} a
  16 consByName a = let cs = conses{|*|}
  17         in ((!!) cs) <$> elemIndex a (map consName{|*|} cs)
  18
  19
  20 generic consName a :: a -> String
  21 consName{|CONS of {gcd_name}|} f x = gcd_name
  22 consName{|UNIT|}   _ = "UNIT"
  23 consName{|PAIR|}   f g (PAIR x y) = f x
  24 consName{|EITHER|} f g (LEFT x)   = f x
  25 consName{|EITHER|} f g (RIGHT y)  = g y
  26 consName{|OBJECT|} f   (OBJECT x) = f x
  27 consName{|RECORD|} f   (RECORD x) = f x
  28 consName{|FIELD|}  f   (FIELD x)  = f x
  29 consName{|Int|}        i = toString i
  30 consName{|Bool|}       b = toString b
  31 consName{|Char|}       c = toString c
  32 consName{|Real|}       r = toString r
  33 consName{|String|}     s = s
  34 consName{|[]|} _ _ = "[]"
  35 consName{|[!]|} _ _ = "[!]"
  36 consName{|[ !]|} _ _ = "[ !]"
  37 consName{|[!!]|} _ _ = "[!!]"
  38 consName{|{}|} _ _ = "{}"
  39 consName{|{!}|} _ _ = "{!}"
  40 consName{|(->)|}   f g x = g (x undef)
  41 consName{|()|} _ = "()"
  42 consName{|(,)|} _ _ _ = "(,)"
  43 consName{|(,,)|}  _ _ _ _ = "(,,)"
  44 consName{|(,,,)|}  _ _ _ _ _ = "(,,,)"
  45 consName{|(,,,,)|}  _ _ _ _ _ _ = "(,,,,)"
  46 consName{|(,,,,,)|}  _ _ _ _ _ _ _ = "(,,,,,)"
  47 consName{|(,,,,,,)|}  _ _ _ _ _ _ _ _ = "(,,,,,,)"
  48 consName{|(,,,,,,,)|}  _ _ _ _ _ _ _ _ _ = "(,,,,,,,)"
  49 consName{|(,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,)"
  50 consName{|(,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,)"
  51 consName{|(,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,)"
  52 consName{|(,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,)"
  53 consName{|(,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,)"
  54 consName{|(,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,)"
  55 consName{|(,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,)"
  56 consName{|(,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,)"
  57 consName{|(,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,)"
  58 consName{|(,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,)"
  59 consName{|(,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,)"
  60 consName{|(,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,)"
  61 consName{|(,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,)"
  62 consName{|(,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,)"
  63 consName{|(,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,)"
  64 consName{|(,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,)"
  65 consName{|(,,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,,)"
  66 consName{|(,,,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,,,)"
  67 consName{|(,,,,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,,,,)"
  68 consName{|(,,,,,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,,,,,)"
  69 consName{|(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)"
  70 consName{|(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)"
  71 consName{|(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)"
  72
  73 generic consIndex a :: a -> Int
  74 consIndex{|CONS of {gcd_index}|} f x = gcd_index
  75 consIndex{|UNIT|} _ = 0
  76 consIndex{|PAIR|} f g (PAIR x y) = f x
  77 consIndex{|EITHER|} f g (LEFT x) = f x
  78 consIndex{|EITHER|} f g (RIGHT y) = g y
  79 consIndex{|OBJECT|} f (OBJECT x) = f x
  80 consIndex{|RECORD|} f (RECORD x) = f x
  81 consIndex{|FIELD|} f (FIELD x) = f x
  82 consIndex{|Int|} i = i
  83 consIndex{|Bool|} b = if b 1 0
  84 consIndex{|Char|} c = toInt c
  85 consIndex{|Real|} r = toInt r
  86 consIndex{|String|} _ = 0
  87 consIndex{|{}|} _ _ = 0
  88 consIndex{|{!}|} _ _ = 0
  89 consIndex{|(->)|} _ _ _ = 0
  90 derive consIndex [],[!],[ !],[!!],(),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
  91
  92 generic conses a :: [a]
  93 conses{|CONS|} f = [CONS (hd f)]
  94 conses{|UNIT|} = [UNIT]
  95 conses{|PAIR|} f g = []
  96 conses{|EITHER|} f g = map LEFT f ++ map RIGHT g
  97 conses{|OBJECT|} f = map OBJECT f
  98 conses{|RECORD|} f = map RECORD f
  99 conses{|FIELD|} f = map FIELD f
 100 conses{|Int|} = [0]
 101 conses{|Bool|} = [True]
 102 conses{|Char|} = ['\0']
 103 conses{|Real|} = [0.0]
 104 conses{|String|} = [""]
 105 conses{|{}|} _ = [{}]
 106 conses{|{!}|} _ = [{!}]
 107 conses{|(->)|} _ _ = [const undef]
 108 derive conses [],[!],[ !],[!!],(),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
 109
 110 generic consNum a :: a -> Int
 111 consNum{|CONS of {gcd_arity}|} f x = gcd_arity
 112 consNum{|UNIT|} _ = 0
 113 consNum{|PAIR|} f _ (PAIR x y) = f x
 114 consNum{|EITHER|} f _ (LEFT x) = f x
 115 consNum{|EITHER|} _ g (RIGHT y) = g y
 116 consNum{|OBJECT|} f (OBJECT x) = f x
 117 consNum{|RECORD|} f (RECORD x) = f x
 118 consNum{|FIELD|} f (FIELD x) = f x
 119 consNum{|Int|} _ = 0
 120 consNum{|Bool|} _ = 0
 121 consNum{|Char|} _ = 0
 122 consNum{|Real|} _ = 0
 123 consNum{|String|} _ = 0
 124 consNum{|{}|} _ _ = 0
 125 consNum{|{!}|} _ _ = 0
 126 consNum{|(->)|} _ _ _ = 0
 127 derive consNum [],[!],[ !],[!!],(),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)