--- /dev/null
+implementation module GenFMap \r
+\r
+import StdGeneric, StdEnv, StdMaybe, _Array, GenMonad\r
+\r
+derive bimap (,), [] \r
+\r
+:: FMap v \r
+ = FMEmpty\r
+ | FMValue v\r
+ | FMEither .(FMap v) .(FMap v)\r
+ | FMChar .[.(Char, .FMap v)]\r
+ | FMInt .[.(Int, .FMap v)]\r
+ | FMReal .[.(Real, .FMap v)]\r
+\r
+emptyFMap :: .FMap .v\r
+emptyFMap = FMEmpty\r
+\r
+lookupAssocList :: k v [(k,v)] -> v | == k\r
+lookupAssocList key default_val [] = default_val\r
+lookupAssocList key default_val [(k,v):xs]\r
+ | key == k\r
+ = v\r
+ = lookupAssocList key default_val xs \r
+ \r
+updateAssocList :: k v v [(k,v)] -> (v, [(k,v)]) | == k\r
+updateAssocList key value default_val [] = (default_val, [(key, value)])\r
+updateAssocList key value default_val [(k,v):xs]\r
+ | k == key\r
+ = (v, [(k, value):xs])\r
+ #! (old_val, xs) = updateAssocList key value default_val xs\r
+ = (old_val, [(k, v) : xs]) \r
+ \r
+derive bimap FMap, Maybe\r
+bimap{|{}|} bma = {map_to = mapArray bma.map_to, map_from = mapArray bma.map_from}\r
+\r
+generic gLookupFMap key :: key (FMap value) -> FMap value\r
+gLookupFMap{|Char|} key (FMChar xs) = lookupAssocList key FMEmpty xs\r
+gLookupFMap{|Char|} key FMEmpty = FMEmpty\r
+\r
+gLookupFMap{|Int|} key (FMInt xs) = lookupAssocList key FMEmpty xs\r
+gLookupFMap{|Int|} key FMEmpty = FMEmpty\r
+\r
+gLookupFMap{|Real|} key (FMReal xs) = lookupAssocList key FMEmpty xs\r
+gLookupFMap{|Real|} key FMEmpty = FMEmpty\r
+\r
+gLookupFMap{|Bool|} False (FMEither ls rs) = ls\r
+gLookupFMap{|Bool|} True (FMEither ls rs) = rs\r
+gLookupFMap{|Bool|} key FMEmpty = FMEmpty\r
+\r
+//gLookupFMap{|UNIT|} key (FMValue v) = (FMValue v)\r
+//gLookupFMap{|UNIT|} key FMEmpty = FMEmpty\r
+gLookupFMap{|UNIT|} key fm = fm\r
+\r
+gLookupFMap{|PAIR|} fx fy (PAIR kx ky) fm = fy ky (fx kx fm)\r
+\r
+gLookupFMap{|EITHER|} fl fr (LEFT key) (FMEither ls rs) = fl key ls\r
+gLookupFMap{|EITHER|} fl fr (RIGHT key) (FMEither ls rs) = fr key rs\r
+gLookupFMap{|EITHER|} fl fr key FMEmpty = FMEmpty \r
+\r
+gLookupFMap{|CONS|} f (CONS key) fm = f key fm\r
+gLookupFMap{|FIELD|} f (FIELD key) fm = f key fm\r
+gLookupFMap{|OBJECT|} f (OBJECT key) fm = f key fm\r
+\r
+derive gLookupFMap []\r
+\r
+gLookupFMap{|String|} arr fm = gLookupFMap{|*|} [x\\x<-:arr] fm\r
+gLookupFMap{|{}|} f arr fm = gLookupFMap{|*->*|} f [x\\x<-:arr] fm\r
+gLookupFMap{|{!}|} f arr fm = gLookupFMap{|*->*|} f [x\\x<-:arr] fm\r
+\r
+derive gLookupFMap (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+lookupFMap :: !k .(FMap v) -> .(Maybe v) | gLookupFMap{|*|} k & bimap{|*|} v\r
+lookupFMap key fmap = case gLookupFMap{|*|} key fmap of\r
+ FMValue v -> Just v\r
+ FMEmpty -> Nothing \r
+ _ -> abort "erroneous FMap"\r
+\r
+\r
+//------------------------------------------------------------------------------------\r
+\r
+generic gInsertFMap key :: key (FMap value, FMap value) -> (FMap value, FMap value)\r
+\r
+gInsertFMap{|Char|} key (new_val, FMChar xs) \r
+ # (old_val, xs) = updateAssocList key new_val FMEmpty xs\r
+ = (old_val, FMChar xs)\r
+gInsertFMap{|Char|} key (new_val, FMEmpty) \r
+ = (FMEmpty, FMChar [(key, new_val)])\r
+\r
+gInsertFMap{|Int|} key (new_val, FMInt xs) \r
+ # (old_val, xs) = updateAssocList key new_val FMEmpty xs\r
+ = (old_val, FMInt xs)\r
+gInsertFMap{|Int|} key (new_val, FMEmpty) \r
+ = (FMEmpty, FMInt [(key, new_val)])\r
+\r
+gInsertFMap{|Real|} key (new_val, FMReal xs) \r
+ # (old_val, xs) = updateAssocList key new_val FMEmpty xs\r
+ = (old_val, FMReal xs)\r
+gInsertFMap{|Real|} key (new_val, FMEmpty) \r
+ = (FMEmpty, FMReal [(key, new_val)])\r
+\r
+gInsertFMap{|Bool|} False (v, FMEither ls rs) = (ls, FMEither v rs)\r
+gInsertFMap{|Bool|} False (v, FMEmpty) = (FMEmpty, FMEither v FMEmpty)\r
+gInsertFMap{|Bool|} True (v, FMEither ls rs) = (rs, FMEither ls v)\r
+gInsertFMap{|Bool|} True (v, FMEmpty) = (FMEmpty, FMEither FMEmpty v)\r
+ \r
+gInsertFMap{|UNIT|} key (x, y) = (y, x)\r
+\r
+gInsertFMap{|PAIR|} fx fy (PAIR kx ky) (new_val, fmx) \r
+ #! (old_fmy, fmx1) = fx kx (FMEmpty, fmx)\r
+ #! (old_val, new_fmy) = fy ky (new_val, old_fmy) \r
+ #! (empty_fmy, new_fmx) = fx kx (new_fmy, fmx) \r
+ = (old_val, new_fmx)\r
+\r
+gInsertFMap{|EITHER|} fl fr (LEFT key) (v, FMEither ls rs) \r
+ # (old_val, new_ls) = fl key (v,ls)\r
+ = (old_val, FMEither new_ls rs)\r
+gInsertFMap{|EITHER|} fl fr (LEFT key) (v, FMEmpty)\r
+ # (old_val, new_ls) = fl key (v,FMEmpty)\r
+ = (FMEmpty, FMEither new_ls FMEmpty)\r
+gInsertFMap{|EITHER|} fl fr (RIGHT key) (v, FMEither ls rs)\r
+ # (old_val, new_rs) = fr key (v,rs)\r
+ = (old_val, FMEither ls new_rs)\r
+gInsertFMap{|EITHER|} fl fr (RIGHT key) (v, FMEmpty)\r
+ # (old_val, new_rs) = fr key (v,FMEmpty)\r
+ = (FMEmpty, FMEither FMEmpty new_rs)\r
+ \r
+gInsertFMap{|CONS|} f (CONS key) x = f key x\r
+gInsertFMap{|FIELD|} f (FIELD key) x = f key x\r
+gInsertFMap{|OBJECT|} f (OBJECT key) x = f key x\r
+\r
+derive gInsertFMap []\r
+\r
+gInsertFMap{|String|} xs fm = gInsertFMap{|*|} [x\\x<-:xs] fm\r
+gInsertFMap{|{}|} f xs fm = gInsertFMap{|*->*|} f [x\\x<-:xs] fm\r
+gInsertFMap{|{!}|} f xs fm = gInsertFMap{|*->*|} f [x\\x<-:xs] fm\r
+\r
+derive gInsertFMap (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+(<<=) infixl 1 :: .(FMap v) !.(k,v) -> FMap v | gInsertFMap{|*|} k & bimap{|*|} v\r
+(<<=) fmap (key, value)\r
+ #! (old_val, fmap) = gInsertFMap{|*|} key (FMValue value, fmap)\r
+ = fmap \r
+\r
+//-----------------------------------------------------------------------------\r
+/* \r
+fmap = FMEmpty \r
+ <<= ("one", 1)\r
+ <<= ("two", 2)\r
+ <<= ("three", 3)\r
+ <<= ("four", 4)\r
+\r
+Start = lookupFMap "two" fmap \r
+*/\r
repositories / tt2015.git / blobdiff