+++ /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