a3/code/Generics/GenFMap.icl

   1 implementation module GenFMap
   2
   3 import StdGeneric, StdEnv, StdMaybe, _Array, GenMonad
   4
   5 derive bimap (,), []
   6
   7 :: FMap v
   8         = FMEmpty
   9         | FMValue v
  10         | FMEither      .(FMap v) .(FMap v)
  11         | FMChar .[.(Char, .FMap v)]
  12         | FMInt  .[.(Int, .FMap v)]
  13         | FMReal .[.(Real, .FMap v)]
  14
  15 emptyFMap :: .FMap .v
  16 emptyFMap = FMEmpty
  17
  18 lookupAssocList :: k v [(k,v)] -> v | == k
  19 lookupAssocList key default_val [] = default_val
  20 lookupAssocList key default_val [(k,v):xs]
  21         | key == k
  22                 = v
  23                 = lookupAssocList key default_val xs
  24
  25 updateAssocList :: k v v [(k,v)] -> (v, [(k,v)]) | == k
  26 updateAssocList key value default_val [] = (default_val, [(key, value)])
  27 updateAssocList key value default_val [(k,v):xs]
  28         | k == key
  29                 = (v, [(k, value):xs])
  30                 #! (old_val, xs) = updateAssocList key value default_val xs
  31                 = (old_val, [(k, v) : xs])
  32
  33 derive bimap FMap, Maybe
  34 bimap{|{}|} bma = {map_to = mapArray bma.map_to, map_from = mapArray bma.map_from}
  35
  36 generic gLookupFMap key :: key (FMap value) -> FMap value
  37 gLookupFMap{|Char|} key (FMChar xs) = lookupAssocList key FMEmpty xs
  38 gLookupFMap{|Char|} key FMEmpty         = FMEmpty
  39
  40 gLookupFMap{|Int|} key (FMInt xs) = lookupAssocList key FMEmpty xs
  41 gLookupFMap{|Int|} key FMEmpty  = FMEmpty
  42
  43 gLookupFMap{|Real|} key (FMReal xs) = lookupAssocList key FMEmpty xs
  44 gLookupFMap{|Real|} key FMEmpty         = FMEmpty
  45
  46 gLookupFMap{|Bool|} False (FMEither ls rs)      = ls
  47 gLookupFMap{|Bool|} True  (FMEither ls rs)      = rs
  48 gLookupFMap{|Bool|} key FMEmpty                         = FMEmpty
  49
  50 //gLookupFMap{|UNIT|} key (FMValue v)   = (FMValue v)
  51 //gLookupFMap{|UNIT|} key FMEmpty               = FMEmpty
  52 gLookupFMap{|UNIT|} key fm              = fm
  53
  54 gLookupFMap{|PAIR|} fx fy (PAIR kx ky) fm = fy ky (fx kx fm)
  55
  56 gLookupFMap{|EITHER|} fl fr (LEFT key) (FMEither ls rs) = fl key ls
  57 gLookupFMap{|EITHER|} fl fr (RIGHT key) (FMEither ls rs) = fr key rs
  58 gLookupFMap{|EITHER|} fl fr key FMEmpty         = FMEmpty
  59
  60 gLookupFMap{|CONS|} f (CONS key) fm = f key fm
  61 gLookupFMap{|FIELD|} f (FIELD key) fm = f key fm
  62 gLookupFMap{|OBJECT|} f (OBJECT key) fm = f key fm
  63
  64 derive gLookupFMap []
  65
  66 gLookupFMap{|String|} arr fm = gLookupFMap{|*|} [x\\x<-:arr] fm
  67 gLookupFMap{|{}|} f arr fm = gLookupFMap{|*->*|} f [x\\x<-:arr] fm
  68 gLookupFMap{|{!}|} f arr fm = gLookupFMap{|*->*|} f [x\\x<-:arr] fm
  69
  70 derive gLookupFMap (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
  71
  72 lookupFMap :: !k .(FMap v) -> .(Maybe v) | gLookupFMap{|*|} k & bimap{|*|} v
  73 lookupFMap key fmap = case gLookupFMap{|*|} key fmap of
  74         FMValue v       -> Just v
  75         FMEmpty         -> Nothing
  76         _                       -> abort "erroneous FMap"
  77
  78
  79 //------------------------------------------------------------------------------------
  80
  81 generic gInsertFMap key :: key (FMap value, FMap value) -> (FMap value, FMap value)
  82
  83 gInsertFMap{|Char|} key (new_val, FMChar xs)
  84         # (old_val, xs) = updateAssocList key new_val FMEmpty xs
  85         = (old_val, FMChar xs)
  86 gInsertFMap{|Char|} key (new_val, FMEmpty)
  87         = (FMEmpty, FMChar [(key, new_val)])
  88
  89 gInsertFMap{|Int|} key (new_val, FMInt xs)
  90         # (old_val, xs) = updateAssocList key new_val FMEmpty xs
  91         = (old_val, FMInt xs)
  92 gInsertFMap{|Int|} key (new_val, FMEmpty)
  93         = (FMEmpty, FMInt [(key, new_val)])
  94
  95 gInsertFMap{|Real|} key (new_val, FMReal xs)
  96         # (old_val, xs) = updateAssocList key new_val FMEmpty xs
  97         = (old_val, FMReal xs)
  98 gInsertFMap{|Real|} key (new_val, FMEmpty)
  99         = (FMEmpty, FMReal [(key, new_val)])
 100
 101 gInsertFMap{|Bool|} False (v, FMEither ls rs)   = (ls, FMEither v rs)
 102 gInsertFMap{|Bool|} False (v, FMEmpty)                  = (FMEmpty, FMEither v FMEmpty)
 103 gInsertFMap{|Bool|} True  (v, FMEither ls rs)   = (rs, FMEither ls v)
 104 gInsertFMap{|Bool|} True  (v, FMEmpty)                  = (FMEmpty, FMEither FMEmpty v)
 105
 106 gInsertFMap{|UNIT|} key (x, y)          = (y, x)
 107
 108 gInsertFMap{|PAIR|} fx fy (PAIR kx ky) (new_val, fmx)
 109         #! (old_fmy, fmx1) = fx kx (FMEmpty, fmx)
 110         #! (old_val, new_fmy) = fy ky (new_val, old_fmy)
 111         #! (empty_fmy, new_fmx) = fx kx (new_fmy, fmx)
 112         = (old_val, new_fmx)
 113
 114 gInsertFMap{|EITHER|} fl fr (LEFT key) (v, FMEither ls rs)
 115         # (old_val, new_ls) = fl key (v,ls)
 116         = (old_val, FMEither new_ls rs)
 117 gInsertFMap{|EITHER|} fl fr (LEFT key) (v, FMEmpty)
 118         # (old_val, new_ls) = fl key (v,FMEmpty)
 119         = (FMEmpty, FMEither new_ls FMEmpty)
 120 gInsertFMap{|EITHER|} fl fr (RIGHT key) (v, FMEither ls rs)
 121         # (old_val, new_rs) = fr key (v,rs)
 122         = (old_val, FMEither ls new_rs)
 123 gInsertFMap{|EITHER|} fl fr (RIGHT key) (v, FMEmpty)
 124         # (old_val, new_rs) = fr key (v,FMEmpty)
 125         = (FMEmpty, FMEither FMEmpty new_rs)
 126
 127 gInsertFMap{|CONS|} f (CONS key) x = f key x
 128 gInsertFMap{|FIELD|} f (FIELD key) x = f key x
 129 gInsertFMap{|OBJECT|} f (OBJECT key) x = f key x
 130
 131 derive gInsertFMap []
 132
 133 gInsertFMap{|String|} xs fm = gInsertFMap{|*|} [x\\x<-:xs] fm
 134 gInsertFMap{|{}|} f xs fm = gInsertFMap{|*->*|} f [x\\x<-:xs] fm
 135 gInsertFMap{|{!}|} f xs fm = gInsertFMap{|*->*|} f [x\\x<-:xs] fm
 136
 137 derive gInsertFMap (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
 138
 139 (<<=) infixl 1 :: .(FMap v) !.(k,v) -> FMap v | gInsertFMap{|*|} k & bimap{|*|} v
 140 (<<=) fmap (key, value)
 141         #! (old_val, fmap) = gInsertFMap{|*|} key (FMValue value, fmap)
 142         = fmap
 143
 144 //-----------------------------------------------------------------------------
 145 /*
 146 fmap = FMEmpty
 147         <<= ("one", 1)
 148         <<= ("two", 2)
 149         <<= ("three", 3)
 150         <<= ("four", 4)
 151
 152 Start = lookupFMap "two" fmap
 153 */