--- /dev/null
+definition module GenBimap\r
+\r
+// from StdGeneric import generic bimap\r
+import StdGeneric\r
+from StdMaybe import :: Maybe\r
+\r
+derive bimap Maybe, [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
--- /dev/null
+implementation module GenBimap\r
+\r
+import GenBimap\r
+\r
+derive bimap Maybe, [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
--- /dev/null
+definition module GenCompress\r
+\r
+import StdGeneric, StdMaybe\r
+\r
+:: BitVector :== {#Int}\r
+\r
+:: CompressSt\r
+\r
+generic gCompress a :: !a -> *CompressSt -> *CompressSt\r
+derive gCompress Int, Real, Bool, Char, String, UNIT, PAIR, EITHER, CONS, FIELD, OBJECT, [], {}, {!}\r
+\r
+generic gCompressedSize a :: a -> Int\r
+derive gCompressedSize Int, Real, Bool, Char, String, UNIT, PAIR, EITHER, CONS, FIELD, OBJECT, [], {}, {!}\r
+\r
+generic gUncompress a :: (u:CompressSt -> ((Maybe a),u:CompressSt))\r
+derive gUncompress Int, Real, Bool, Char, String, UNIT, PAIR, EITHER, CONS, FIELD, OBJECT, [], {}, {!}\r
+\r
+compress :: !a -> BitVector | gCompressedSize{|*|} a & gCompress{|*|} a\r
+uncompress :: (BitVector -> Maybe a) | gUncompress{|*|} a\r
--- /dev/null
+implementation module GenCompress\r
+\r
+import StdGeneric, StdEnv, StdMaybe, _Array\r
+\r
+//--------------------------------------------------\r
+// uncompressor monad\r
+\r
+ret :: !.a !u:CompressSt -> (!Maybe .a,!u:CompressSt)\r
+ret a st = (Just a, st)\r
+(>>=) infixl 5 \r
+(>>=) pa pb = bind pa pb\r
+where\r
+ bind pa pb st \r
+ #! (ma, st) = pa st\r
+ = case ma of\r
+ Nothing -> (Nothing, st)\r
+ Just x -> pb x st\r
+\r
+//--------------------------------------------------\r
+\r
+:: BitVector :== {#Int}\r
+:: BitPos :== Int\r
+\r
+:: CompressSt = { cs_pos :: !Int, cs_bits :: !.{#Int} }\r
+mkCompressSt arr = { cs_pos = 0, cs_bits = arr}\r
+\r
+\r
+:: Compress a :== a -> *CompressSt -> *CompressSt\r
+:: Uncompress a :== .CompressSt -> .(.(Maybe a), .CompressSt)\r
+\r
+compressBool :: !Bool !*CompressSt -> *CompressSt\r
+compressBool bit {cs_pos = pos, cs_bits = bits}\r
+ #! s = size bits\r
+ #! int_pos = pos >> (IF_INT_64_OR_32 6 5)\r
+ #! bit_pos = pos bitand (IF_INT_64_OR_32 63 31)\r
+ | s == int_pos\r
+ = abort "reallocate" \r
+ #! int = bits.[int_pos]\r
+ #! bit_mask = 1 << bit_pos\r
+ #! new_int = if bit (int bitor bit_mask) (int bitand (bitnot bit_mask))\r
+ = {cs_pos = inc pos, cs_bits = {bits & [int_pos] = new_int}}\r
+\r
+uncompressBool :: !u:CompressSt -> (.(Maybe Bool),v:CompressSt), [u <= v]\r
+uncompressBool cs=:{cs_pos = pos, cs_bits = bits}\r
+ #! s = size bits\r
+ #! int_pos = pos >> (IF_INT_64_OR_32 6 5)\r
+ #! bit_pos = pos bitand (IF_INT_64_OR_32 63 31)\r
+ | s == int_pos\r
+ = (Nothing, cs) \r
+ #! int = bits.[int_pos]\r
+ #! bit_mask = 1 << bit_pos\r
+ #! bit = (bit_mask bitand int) <> 0\r
+ = (Just bit, {cs & cs_pos = inc pos})\r
+\r
+compressIntB :: !.Int !.Int -> .(*CompressSt -> .CompressSt)\r
+compressIntB num_bits int\r
+ = compress 0 num_bits int\r
+where\r
+ compress i n int\r
+ | i == n\r
+ = id\r
+ | otherwise\r
+ = compress (inc i) n (int >> 1) \r
+ o compressBool ((int bitand 1) == 1)\r
+\r
+\r
+compressInt = compressIntB (IF_INT_64_OR_32 64 32)\r
+compressChar c = compressIntB 8 (toInt c)\r
+\r
+uncompressIntB :: !.Int -> u:CompressSt -> (.(Maybe Int),v:CompressSt), [u <= v]\r
+uncompressIntB num_bits\r
+ = uncompress 0 num_bits 0\r
+where\r
+ uncompress i n int\r
+ | i == n\r
+ = ret int\r
+ | otherwise\r
+ = uncompressBool\r
+ >>= \bit -> uncompress (inc i) n int \r
+ >>= \x -> ret ((if bit 1 0) + (x << 1))\r
+\r
+uncompressInt :: (u:CompressSt -> (.(Maybe Int),v:CompressSt)), [u <= v]\r
+uncompressInt = uncompressIntB (IF_INT_64_OR_32 64 32)\r
+\r
+uncompressChar :: (u:CompressSt -> (.(Maybe Char),v:CompressSt)), [u <= v]\r
+uncompressChar = uncompressIntB 8 >>= ret o toChar \r
+\r
+realToBinary32 :: !Real -> (!Int,!Int);\r
+realToBinary32 _ = code {\r
+ pop_b 0\r
+ };\r
+\r
+realToBinary64 :: !Real -> Int;\r
+realToBinary64 _ = code {\r
+ pop_b 0\r
+ };\r
+\r
+binaryToReal32 :: !(!Int,!Int) -> Real;\r
+binaryToReal32 _ = code {\r
+ pop_b 0\r
+ };\r
+\r
+binaryToReal64 :: !Int -> Real;\r
+binaryToReal64 _ = code {\r
+ pop_b 0\r
+ };\r
+\r
+compressReal real\r
+ = IF_INT_64_OR_32\r
+ (compressInt (realToBinary64 real))\r
+ (let (i1, i2) = realToBinary32 real in compressInt i2 o compressInt i1)\r
+\r
+uncompressReal :: (u:CompressSt -> (.(Maybe Real),v:CompressSt)), [u <= v]\r
+uncompressReal\r
+ = IF_INT_64_OR_32\r
+ (uncompressInt\r
+ >>= \i -> ret (binaryToReal64 i))\r
+ (uncompressInt \r
+ >>= \i1 -> uncompressInt \r
+ >>= \i2 -> ret (binaryToReal32 (i1,i2)))\r
+\r
+compressArray :: (a -> u:(v:CompressSt -> w:CompressSt)) !.(b a) -> x:(*CompressSt -> y:CompressSt) | Array b a, [x <= u,w <= v,w <= y]\r
+compressArray f xs \r
+ = foldSt f [x \\ x <-: xs] o compressInt (size xs)\r
+\r
+foldSt f [] = id\r
+foldSt f [x:xs] = foldSt f xs o f x\r
+\r
+uncompressArray :: (u:CompressSt -> ((Maybe v:a),w:CompressSt)) -> .(x:CompressSt -> ((Maybe y:(b v:a)),z:CompressSt)) | Array b a, [x w <= u,y <= v,x w <= z]\r
+uncompressArray f \r
+ = uncompressInt >>= \s -> uncompress_array 0 s (createArrayUnsafe s) \r
+where \r
+ uncompress_array i s arr\r
+ | i == s\r
+ = ret arr\r
+ = f >>= \x -> uncompress_array (inc i) s {arr & [i] = x} \r
+\r
+compressList :: (a *CompressSt -> *CompressSt) ![a] -> *CompressSt -> *CompressSt\r
+compressList c xs = compressArray c (list_to_arr xs)\r
+where\r
+ list_to_arr :: [b] -> {b} | Array {} b\r
+ list_to_arr xs = {x \\ x <- xs}\r
+\r
+\r
+uncompressList xs = uncompressArray xs >>= ret o arr_to_list\r
+where\r
+ arr_to_list :: {b} -> [b] | Array {} b\r
+ arr_to_list xs = [x \\ x <-: xs] \r
+ \r
+//--------------------------------------------------------------------------------------\r
+\r
+generic gCompress a :: !a -> *CompressSt -> *CompressSt\r
+gCompress{|Int|} x = compressInt x \r
+gCompress{|Real|} x = compressReal x \r
+gCompress{|Char|} x = compressChar x\r
+gCompress{|Bool|} x = compressBool x\r
+gCompress{|UNIT|} x = id\r
+gCompress{|PAIR|} cx cy (PAIR x y) = cy y o cx x\r
+gCompress{|EITHER|} cl cr (LEFT x) = cl x o compressBool False\r
+gCompress{|EITHER|} cl cr (RIGHT x) = cr x o compressBool True\r
+gCompress{|CONS|} c (CONS x) = c x\r
+gCompress{|FIELD|} c (FIELD x) = c x\r
+gCompress{|OBJECT|} c (OBJECT x) = c x\r
+gCompress{|{}|} c xs = compressArray c xs\r
+gCompress{|{!}|} c xs = compressArray c xs\r
+gCompress{|String|} xs = compressArray compressChar xs\r
+gCompress{|[]|} c xs = compressList c xs\r
+\r
+\r
+generic gCompressedSize a :: a -> Int\r
+gCompressedSize{|Int|} _ = IF_INT_64_OR_32 64 32\r
+gCompressedSize{|Real|} _ = 64\r
+gCompressedSize{|Char|} _ = 8\r
+gCompressedSize{|Bool|} _ = 1\r
+gCompressedSize{|UNIT|} _ = 0\r
+gCompressedSize{|PAIR|} cx cy (PAIR x y) = cx x + cy y\r
+gCompressedSize{|EITHER|} cl cr (LEFT x) = 1 + cl x\r
+gCompressedSize{|EITHER|} cl cr (RIGHT x) = 1 + cr x\r
+gCompressedSize{|CONS|} c (CONS x) = c x\r
+gCompressedSize{|FIELD|} c (FIELD x) = c x\r
+gCompressedSize{|OBJECT|} c (OBJECT x) = c x\r
+gCompressedSize{|[]|} c xs = foldSt (\x st -> c x + st) xs (IF_INT_64_OR_32 64 32) \r
+gCompressedSize{|{}|} c xs = foldSt (\x st -> c x + st) [x\\x<-:xs] (IF_INT_64_OR_32 64 32) \r
+gCompressedSize{|{!}|} c xs = foldSt (\x st -> c x + st) [x\\x<-:xs] (IF_INT_64_OR_32 64 32) \r
+gCompressedSize{|String|} xs = (IF_INT_64_OR_32 64 32) + size xs * 8\r
+\r
+generic gUncompress a :: (u:CompressSt -> ((Maybe a),u:CompressSt))\r
+gUncompress{|Int|} = uncompressInt\r
+gUncompress{|Real|} = uncompressReal\r
+gUncompress{|Char|} = uncompressChar\r
+gUncompress{|Bool|} = uncompressBool\r
+gUncompress{|UNIT|} = ret UNIT\r
+gUncompress{|PAIR|} fx fy = fx >>= \x -> fy >>= \y -> ret (PAIR x y)\r
+gUncompress{|EITHER|} fl fr = uncompressBool >>= either\r
+where\r
+ either is_right \r
+ | is_right\r
+ = fr >>= ret o RIGHT\r
+ = fl >>= ret o LEFT\r
+gUncompress{|CONS|} f = f >>= ret o CONS\r
+gUncompress{|FIELD|} f = f >>= ret o FIELD\r
+gUncompress{|OBJECT|} f = f >>= ret o OBJECT\r
+gUncompress{|[]|} f = uncompressList f \r
+gUncompress{|{}|} f = uncompressArray f \r
+gUncompress{|{!}|} f = uncompressArray f \r
+gUncompress{|String|} = uncompressArray uncompressChar \r
+\r
+\r
+//-------------------------------------------------------------------------------------\r
+\r
+uncompress :: (BitVector -> Maybe a) | gUncompress{|*|} a\r
+uncompress = fst o gUncompress{|*|} o mkCompressSt\r
+\r
+compress :: !a -> BitVector | gCompressedSize{|*|} a & gCompress{|*|} a\r
+compress x \r
+ #! compressed_size = gCompressedSize{|*|} x\r
+ #! arr_size = (compressed_size + (IF_INT_64_OR_32 63 31)) >> (IF_INT_64_OR_32 6 5)\r
+ #! bits = createArray arr_size 0\r
+ = (gCompress{|*|} x (mkCompressSt bits)).cs_bits\r
+ \r
+//-------------------------------------------------------------------------------------\r
+\r
+/*\r
+:: Tree a b = Tip a | Bin b (Tree a b) (Tree a b)\r
+:: Color = Red | Green | Blue\r
+\r
+derive bimap (,), (,,), Maybe\r
+derive gCompress Tree, Color\r
+derive gUncompress Tree, Color\r
+derive gCompressedSize Tree, Color\r
+ \r
+//Start :: Maybe (Tree Color Color)\r
+//Start = uncompress (compress (Bin Red (Bin Green (Tip Blue) (Tip Red)) (Tip Green)))\r
+//Start = gCompressedSize{|*|} (Bin Red (Bin Green (Tip Blue) (Tip Red)) (Tip Green))\r
+\r
+Start \r
+ = gCompressedSize{|*|} xs\r
+*/
\ No newline at end of file
--- /dev/null
+definition module GenDefault\r
+\r
+import StdGeneric\r
+\r
+generic gDefault a :: a \r
+\r
+derive gDefault Int, Real, String, PAIR, EITHER, CONS, FIELD, OBJECT \r
+\r
+derive gDefault [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
--- /dev/null
+implementation module GenDefault\r
+\r
+//import StdClass, StdArray, StdInt, StdFunc\r
+import StdGeneric\r
+\r
+generic gDefault a :: a \r
+gDefault{|Int|} = 0\r
+gDefault{|Real|} = 0.0\r
+gDefault{|String|} = ""\r
+gDefault{|UNIT|} = UNIT\r
+gDefault{|EITHER|} dl dr = RIGHT dr\r
+gDefault{|EITHER|} dl dr = LEFT dl\r
+gDefault{|PAIR|} dl dr = PAIR dl dr\r
+gDefault{|CONS|} dc = CONS dc\r
+gDefault{|FIELD|} df = FIELD df\r
+gDefault{|OBJECT|} do = OBJECT do\r
+\r
+derive gDefault [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
--- /dev/null
+definition module GenEq\r
+\r
+import StdGeneric\r
+\r
+generic gEq a :: a a -> Bool\r
+\r
+// base cases\r
+derive gEq Int, Char, Bool, Real, String, UNIT, PAIR, EITHER, CONS, FIELD, OBJECT, {}, {!} \r
+\r
+// standard types\r
+derive gEq [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+(===) infix 4 :: a a -> Bool | gEq{|*|} a\r
+(=!=) infix 4 :: a a -> Bool | gEq{|*|} a\r
--- /dev/null
+implementation module GenEq\r
+\r
+import StdGeneric, StdEnv\r
+\r
+generic gEq a :: a a -> Bool\r
+gEq{|Int|} x y = x == y\r
+gEq{|Char|} x y = x == y\r
+gEq{|Bool|} x y = x == y\r
+gEq{|Real|} x y = x == y\r
+gEq{|String|} x y = x == y\r
+gEq{|UNIT|} UNIT UNIT = True\r
+gEq{|PAIR|} fx fy (PAIR x1 y1) (PAIR x2 y2) = fx x1 x2 && fy y1 y2\r
+gEq{|EITHER|} fl fr (LEFT x) (LEFT y) = fl x y\r
+gEq{|EITHER|} fl fr (RIGHT x) (RIGHT y) = fr x y\r
+gEq{|EITHER|} fl fr _ _ = False\r
+gEq{|CONS|} f (CONS x) (CONS y) = f x y\r
+gEq{|FIELD|} f (FIELD x) (FIELD y) = f x y\r
+gEq{|OBJECT|} f (OBJECT x) (OBJECT y) = f x y\r
+gEq{|{}|} f xs ys = eqArray f xs ys\r
+gEq{|{!}|} f xs ys = eqArray f xs ys\r
+\r
+derive gEq [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+\r
+(===) infix 4 :: a a -> Bool | gEq{|*|} a\r
+(===) x y = gEq{|*|} x y\r
+\r
+(=!=) infix 4 :: a a -> Bool | gEq{|*|} a\r
+(=!=) x y = not (x === y)\r
+\r
+eqArray f xs ys = size xs == size ys && eq 0 (size xs) xs ys\r
+where\r
+ eq i n xs ys\r
+ | i == n = True \r
+ | i < n = f xs.[i] ys.[i] && eq (inc i) n xs ys\r
--- /dev/null
+definition module GenFMap\r
+\r
+import StdGeneric, StdMaybe\r
+\r
+:: FMap v\r
+derive bimap FMap\r
+\r
+emptyFMap :: .FMap .v\r
+\r
+generic gLookupFMap key :: key (FMap value) -> FMap value\r
+derive gLookupFMap UNIT, PAIR, EITHER, CONS, FIELD, OBJECT, Char, Int, Bool, Real, String, [], {}, {!}\r
+derive gLookupFMap (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+generic gInsertFMap key :: key (FMap value, FMap value) -> (FMap value, FMap value)\r
+derive gInsertFMap UNIT, PAIR, EITHER, CONS, FIELD, OBJECT, Char, Int, Bool, Real, String, [], {}, {!}\r
+derive gInsertFMap (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+lookupFMap :: !k .(FMap v) -> .(Maybe v) | gLookupFMap{|*|} k & bimap{|*|} v\r
+(<<=) infixl 1 :: .(FMap v) !.(k,v) -> FMap v | gInsertFMap{|*|} k & bimap{|*|} v\r
--- /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
--- /dev/null
+definition module GenHylo\r
+\r
+import StdGeneric, GenMap\r
+\r
+:: Fix f = In (f .(Fix f))\r
+Out :: !u:(Fix v:a) -> v:(a w:(Fix v:a)), [u <= w]\r
+\r
+hylo :: ((.f .b) -> .b) (.a -> (.f .a)) -> (.a -> .b) | gMap{|*->*|} f\r
+cata :: (u:(f .a) -> .a) -> (Fix u:f) -> .a | gMap{|*->*|} f\r
+ana :: (.a -> u:(f .a)) -> .a -> (Fix u:f) | gMap{|*->*|} f\r
+\r
--- /dev/null
+implementation module GenHylo \r
+\r
+import StdGeneric, GenMap, StdFunc\r
+\r
+:: Fix f = In (f .(Fix f))\r
+\r
+Out :: !u:(Fix v:a) -> v:(a w:(Fix v:a)), [u <= w]\r
+Out (In x) = x\r
+\r
+hylo :: ((.f .b) -> .b) (.a -> (.f .a)) -> (.a -> .b) | gMap{|*->*|} f\r
+hylo consume produce = consume o gMap{|*->*|} (hylo consume produce) o produce\r
+\r
+cata :: (u:(f .a) -> .a) -> (Fix u:f) -> .a | gMap{|*->*|} f\r
+cata f = hylo f Out \r
+\r
+ana :: (.a -> u:(f .a)) -> .a -> (Fix u:f) | gMap{|*->*|} f\r
+ana f = hylo In f\r
+\r
--- /dev/null
+definition module GenLexOrd\r
+\r
+import StdGeneric, GenEq\r
+\r
+:: LexOrd = LT |EQ | GT\r
+derive gEq LexOrd\r
+\r
+generic gLexOrd a b :: a b -> LexOrd\r
+\r
+// base cases\r
+derive gLexOrd Char, Bool, Int, Real, String, UNIT, PAIR, EITHER, FIELD, CONS, OBJECT, [], {}, {!}\r
+\r
+// standard types\r
+derive gLexOrd (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+(=?=) infix 4 :: a a -> LexOrd | gLexOrd{|*|} a\r
--- /dev/null
+implementation module GenLexOrd\r
+\r
+import StdEnv\r
+import StdGeneric, GenEq\r
+\r
+:: LexOrd = LT |EQ | GT\r
+derive gEq LexOrd\r
+\r
+generic gLexOrd a b :: a b -> LexOrd\r
+gLexOrd{|Int|} x y\r
+ | x == y = EQ\r
+ | x < y = LT\r
+ = GT\r
+gLexOrd{|Bool|} True True = EQ\r
+gLexOrd{|Bool|} False True = LT\r
+gLexOrd{|Bool|} True False = GT\r
+gLexOrd{|Bool|} False False = EQ\r
+gLexOrd{|Real|} x y\r
+ | x == y = EQ\r
+ | x < y = LT\r
+ = GT\r
+gLexOrd{|Char|} x y\r
+ | x == y = EQ\r
+ | x < y = LT\r
+ = GT\r
+gLexOrd{|String|} x y\r
+ | x == y = EQ\r
+ | x < y = LT\r
+ = GT \r
+gLexOrd{|UNIT|} UNIT UNIT = EQ\r
+gLexOrd{|PAIR|} fx fy (PAIR x1 y1) (PAIR x2 y2) = case fx x1 x2 of\r
+ EQ -> fy y1 y2\r
+ LT -> LT\r
+ GT -> GT\r
+ \r
+gLexOrd{|EITHER|} fl fr (LEFT x) (LEFT y) = fl x y \r
+gLexOrd{|EITHER|} fl fr (LEFT x) (RIGHT y) = LT\r
+gLexOrd{|EITHER|} fl fr (RIGHT x) (LEFT y) = GT\r
+gLexOrd{|EITHER|} fl fr (RIGHT x) (RIGHT y) = fr x y\r
+gLexOrd{|CONS|} f (CONS x) (CONS y) = f x y\r
+gLexOrd{|FIELD|} f (FIELD x) (FIELD y) = f x y\r
+gLexOrd{|OBJECT|} f (OBJECT x) (OBJECT y) = f x y\r
+\r
+// Instance on standard lists is needed because\r
+// standard lists have unnatural internal ordering of constructors: Cons < Nil,\r
+// i.e Cons is LEFT and Nil is RIGHT in the generic representation.\r
+// We want ordering Nil < Cons\r
+gLexOrd{|[]|} f [] [] = EQ\r
+gLexOrd{|[]|} f [] _ = LT\r
+gLexOrd{|[]|} f _ [] = GT\r
+gLexOrd{|[]|} f [x:xs] [y:ys] = gLexOrd{|*->*->*|} f (gLexOrd{|*->*|} f) (PAIR x xs) (PAIR y ys)\r
+\r
+gLexOrd{|{}|} f xs ys = lexOrdArray f xs ys \r
+gLexOrd{|{!}|} f xs ys = lexOrdArray f xs ys \r
+\r
+\r
+// standard types\r
+derive gLexOrd (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+ \r
+(=?=) infix 4 :: a a -> LexOrd | gLexOrd{|*|} a\r
+(=?=) x y = gLexOrd{|*|} x y \r
+\r
+\r
+lexOrdArray f xs ys\r
+ #! size_xs = size xs\r
+ #! size_ys = size ys\r
+ | size_xs < size_ys = LT\r
+ | size_xs > size_ys = GT\r
+ | otherwise = lexord 0 size_xs xs ys\r
+where\r
+ lexord i n xs ys\r
+ | i == n = EQ\r
+ | otherwise = case f xs.[i] ys.[i] of\r
+ LT -> LT\r
+ GT -> GT \r
+ EQ -> lexord (inc i) n xs ys\r
--- /dev/null
+definition module GenLib\r
+\r
+import StdGeneric\r
+\r
+import GenEq\r
+import GenLexOrd\r
+import GenMap\r
+import GenMapSt\r
+import GenReduce\r
+import GenZip \r
+import GenPrint\r
+import GenParse\r
+import GenCompress\r
+import GenMonad\r
+import GenHylo\r
+import GenFMap\r
+import GenBimap
\ No newline at end of file
--- /dev/null
+implementation module GenLib
\ No newline at end of file
--- /dev/null
+definition module GenMap\r
+\r
+import StdGeneric\r
+\r
+generic gMap a b :: .a -> .b\r
+derive gMap c, PAIR, EITHER, CONS, FIELD, OBJECT, {}, {!} \r
+\r
+derive gMap [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
--- /dev/null
+implementation module GenMap\r
+\r
+import StdClass, StdArray, StdInt, StdFunc\r
+import StdGeneric, _Array\r
+\r
+generic gMap a b :: .a -> .b\r
+gMap{|c|} x = x\r
+gMap{|PAIR|} fx fy (PAIR x y) = PAIR (fx x) (fy y) \r
+gMap{|EITHER|} fl fr (LEFT x) = LEFT (fl x)\r
+gMap{|EITHER|} fl fr (RIGHT x) = RIGHT (fr x)\r
+gMap{|CONS|} f (CONS x) = CONS (f x)\r
+gMap{|FIELD|} f (FIELD x) = FIELD (f x)\r
+gMap{|OBJECT|} f (OBJECT x) = OBJECT (f x)\r
+gMap{|{}|} f xs = mapArray f xs\r
+gMap{|{!}|} f xs = mapArray f xs\r
+\r
+derive gMap [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
--- /dev/null
+definition module GenMapSt\r
+\r
+import StdGeneric\r
+\r
+generic gMapLSt a b :: .a .st -> (.b, .st)\r
+derive gMapLSt c, PAIR, EITHER, FIELD, CONS, OBJECT, {}, {!}\r
+derive gMapLSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+generic gMapRSt a b :: .a .st -> (.b, .st)\r
+derive gMapRSt c, PAIR, EITHER, FIELD, CONS, OBJECT, {}, {!} \r
+derive gMapRSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
--- /dev/null
+implementation module GenMapSt\r
+\r
+import StdGeneric, _Array\r
+\r
+derive bimap (,)\r
+\r
+generic gMapLSt a b :: .a .st -> (.b, .st)\r
+gMapLSt{|c|} x st = (x, st)\r
+gMapLSt{|PAIR|} fx fy (PAIR x y) st\r
+ # (x, st) = fx x st \r
+ # (y, st) = fy y st \r
+ = (PAIR x y, st) \r
+gMapLSt{|EITHER|} fl fr x st = mapStEITHER fl fr x st\r
+gMapLSt{|CONS|} f x st = mapStCONS f x st\r
+gMapLSt{|FIELD|} f x st = mapStFIELD f x st\r
+gMapLSt{|OBJECT|} f x st = mapStOBJECT f x st\r
+gMapLSt{|{}|} f x st = mapArrayLSt f x st\r
+gMapLSt{|{!}|} f x st = mapArrayLSt f x st\r
+\r
+derive gMapLSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+generic gMapRSt a b :: .a .st -> (.b, .st)\r
+gMapRSt{|c|} x st = (x, st)\r
+gMapRSt{|PAIR|} fx fy (PAIR x y) st \r
+ # (y, st) = fy y st \r
+ # (x, st) = fx x st \r
+ = (PAIR x y, st) \r
+gMapRSt{|EITHER|} fx fy x st = mapStEITHER fx fy x st \r
+gMapRSt{|CONS|} f x st = mapStCONS f x st\r
+gMapRSt{|FIELD|} f x st = mapStFIELD f x st\r
+gMapRSt{|OBJECT|} f x st = mapStOBJECT f x st\r
+gMapRSt{|{}|} f x st = mapArrayRSt f x st\r
+gMapRSt{|{!}|} f x st = mapArrayRSt f x st\r
+\r
+derive gMapRSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+\r
+mapStEITHER fl fr (LEFT x) st\r
+ # (x, st) = fl x st \r
+ = (LEFT x, st)\r
+mapStEITHER fl fr (RIGHT x) st\r
+ # (x, st) = fr x st \r
+ = (RIGHT x, st)\r
+mapStCONS f (CONS x) st\r
+ # (x, st) = f x st \r
+ = (CONS x, st)\r
+mapStFIELD f (FIELD x) st \r
+ # (x, st) = f x st \r
+ = (FIELD x, st) \r
+mapStOBJECT f (OBJECT x) st \r
+ # (x, st) = f x st \r
+ = (OBJECT x, st) \r
+
\ No newline at end of file
--- /dev/null
+definition module GenMonad\r
+\r
+import StdGeneric, StdMaybe, StdList\r
+\r
+class Monad m where\r
+ ret :: a:a -> m:(m a:a), [m <= a]\r
+ (>>=) infixl 5 :: u:(m .a) v:(.a -> u:(m .b)) -> u:(m .b), [u <= v]\r
+ \r
+:: StMonad s a = { st_monad :: .(s -> *(a, s)) }\r
+derive bimap StMonad\r
+instance Monad Maybe, [], (StMonad .s)\r
+\r
+generic gMapLM a b :: a:a -> m:(m b:b) | Monad m, [m <= b]\r
+derive gMapLM c, PAIR, EITHER, CONS, FIELD, OBJECT\r
+derive gMapLM [], Maybe, (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+generic gMapRM a b :: a:a -> m:(m b:b) | Monad m, [m <= b]\r
+derive gMapRM c, PAIR, EITHER, CONS, FIELD, OBJECT\r
+derive gMapRM [], Maybe, (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
--- /dev/null
+implementation module GenMonad\r
+\r
+import StdGeneric, StdMaybe, StdList, StdFunc\r
+\r
+generic gMapLM a b :: a:a -> m:(m b:b) | Monad m, [m <= b]\r
+gMapLM{|c|} x = ret x\r
+gMapLM{|PAIR|} fx fy (PAIR x y) = fx x >>= \x1 -> fy y >>= \y1 -> ret (PAIR x1 y1) \r
+gMapLM{|EITHER|} fl fr x = mapMEITHER fl fr x \r
+gMapLM{|CONS|} f (CONS x) = f x >>= ret o CONS\r
+gMapLM{|FIELD|} f (FIELD x) = f x >>= ret o FIELD\r
+gMapLM{|OBJECT|} f (OBJECT x) = f x >>= ret o OBJECT\r
+ \r
+generic gMapRM a b :: a:a -> m:(m b:b) | Monad m, [m <= b]\r
+gMapRM{|c|} x = ret x\r
+gMapRM{|PAIR|} fx fy (PAIR x y) = fy y >>= \y1 -> fx x >>= \x1 -> ret (PAIR x1 y1) \r
+gMapRM{|EITHER|} fl fr x = mapMEITHER fl fr x \r
+gMapRM{|CONS|} f (CONS x) = f x >>= ret o CONS\r
+gMapRM{|FIELD|} f (FIELD x) = f x >>= ret o FIELD\r
+gMapRM{|OBJECT|} f (OBJECT x) = f x >>= ret o OBJECT\r
+\r
+derive gMapLM [], Maybe, (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+derive gMapRM [], Maybe, (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+mapMEITHER fl fr (LEFT x) = fl x >>= ret o LEFT\r
+mapMEITHER fl fr (RIGHT x) = fr x >>= ret o RIGHT \r
+\r
+//---------------------------------------------------------------------- \r
+instance Monad Maybe where\r
+ ret x = Just x\r
+ (>>=) Nothing f = Nothing\r
+ (>>=) (Just x) f = f x\r
+\r
+instance Monad [] where\r
+ ret x = [x]\r
+ //(>>=) xs f = flatten (map f xs) // uniqueness typing makes it a problem because f is shared\r
+ (>>=) [x:xs] f = f x\r
+\r
+//-----------------------\r
+// state monad \r
+\r
+//retStMonad :: .a -> .(StMonad .s .a)\r
+retStMonad x = {st_monad = (\s -> (x, s))} \r
+\r
+//bindStMonad :: !.(StMonad .a .b) .(.b -> .(StMonad .a .c)) -> .(StMonad .a .c)\r
+bindStMonad {st_monad} f = {st_monad = \s -> let (a, s1) = st_monad s in (f a).st_monad s1}\r
+\r
+mapFst f (x, y) = (f x, y)\r
+\r
+//mapStMonad :: .(a:a -> .b) !v:(StMonad s:s a:a) -> .(StMonad s:s .b), [v <= a,v <= s]\r
+mapStMonad f {st_monad} = {st_monad = mapFst f o st_monad}\r
+\r
+instance Monad (StMonad .s) where\r
+ ret x = retStMonad x\r
+ (>>=) x f = bindStMonad x f\r
+\r
+derive bimap (,) \r
+derive bimap StMonad
\ No newline at end of file
--- /dev/null
+definition module GenParse\r
+\r
+import StdGeneric, StdMaybe\r
+\r
+class ParseInput s where\r
+ parseInput :: s -> (Maybe Char, s)\r
+\r
+:: StringInput = { si_str :: !String, si_pos :: !Int} \r
+mkStringInput :: String -> StringInput \r
+\r
+instance ParseInput StringInput \r
+instance ParseInput File\r
+\r
+:: Expr\r
+generic gParse a :: Expr -> Maybe a\r
+\r
+derive gParse Int, Char, Bool, Real, String, UNIT, PAIR, EITHER, CONS, FIELD, OBJECT, [], {!}, {}\r
+\r
+parseString :: String -> Maybe a | gParse{|*|} a\r
+parseFile :: File -> Maybe a | gParse{|*|} a
\ No newline at end of file
--- /dev/null
+implementation module GenParse\r
+\r
+import StdGeneric, StdEnv, StdMaybe\r
+\r
+//---------------------------------------------------------------------------\r
+\r
+\r
+:: StringInput = { si_str :: !String, si_pos :: !Int} \r
+\r
+mkStringInput :: String -> StringInput \r
+mkStringInput str = {si_str = str, si_pos = 0}\r
+\r
+instance ParseInput StringInput where\r
+ parseInput s=:{si_pos, si_str}\r
+ #! size_str = size si_str\r
+ | size_str == si_pos \r
+ = (Nothing, {s & si_str = si_str})\r
+ | otherwise\r
+ #! ch = si_str.[si_pos]\r
+ = (Just ch, {s & si_str = si_str, si_pos = inc si_pos})\r
+\r
+instance ParseInput File where \r
+ parseInput file \r
+ # (ok, c, file) = sfreadc file\r
+ | ok\r
+ = (Just c, file)\r
+ = (Nothing, file)\r
+ \r
+//---------------------------------------------------------------------------\r
+\r
+// lex tokens\r
+:: Token \r
+ = TokenInt Int\r
+ | TokenChar Char\r
+ | TokenReal Real \r
+ | TokenBool Bool\r
+ | TokenString String\r
+ | TokenIdent String\r
+ | TokenOpenPar\r
+ | TokenClosePar\r
+ | TokenOpenCurly\r
+ | TokenCloseCurly\r
+ | TokenOpenList\r
+ | TokenCloseList\r
+ | TokenComma\r
+ | TokenEnd\r
+ | TokenError String\r
+\r
+instance toString Token where\r
+ toString (TokenInt x) = toString x\r
+ toString (TokenChar x) = toString x\r
+ toString (TokenReal x) = toString x\r
+ toString (TokenBool x) = toString x\r
+ toString (TokenString x) = x\r
+ toString (TokenIdent x) = x\r
+ toString TokenOpenPar = "("\r
+ toString TokenClosePar = ")"\r
+ toString TokenOpenCurly = "{"\r
+ toString TokenCloseCurly = "}"\r
+ toString TokenOpenList = "["\r
+ toString TokenCloseList = "]" \r
+ toString TokenComma = ","\r
+ toString TokenEnd = "<end>"\r
+ toString (TokenError err) = "<error: " +++ err +++ ">"\r
+\r
+// preparsed expressions\r
+:: Expr \r
+ = ExprInt Int\r
+ | ExprChar Char\r
+ | ExprReal Real \r
+ | ExprBool Bool\r
+ | ExprString String\r
+ | ExprIdent String\r
+ | ExprApp {Expr} \r
+ | ExprTuple {Expr}\r
+ | ExprField String Expr\r
+ | ExprRecord (Maybe String) {Expr}\r
+ | ExprList [Expr]\r
+ | ExprArray [Expr]\r
+ | ExprEnd Token\r
+ | ExprError String\r
+\r
+ // aux\r
+ | ExprUnit\r
+ | ExprAppInInfix {Expr} GenConsAssoc Int GenConsAssoc\r
+ | ExprPair Expr Expr\r
+\r
+\r
+instance toString Expr where\r
+ toString (ExprInt x) = toString x\r
+ toString (ExprChar x) = toString x\r
+ toString (ExprBool x) = toString x\r
+ toString (ExprReal x) = toString x\r
+ toString (ExprString x) = x\r
+ toString (ExprIdent x) = x\r
+ toString (ExprApp xs) = "(" +++ tostr [x\\x<-:xs] +++ ")"\r
+ where\r
+ tostr [] = ""\r
+ tostr [x] = toString x\r
+ tostr [x:xs] = toString x +++ " " +++ tostr xs\r
+ toString (ExprTuple xs) = "(" +++ tostr [x\\x<-:xs] +++ ")"\r
+ where\r
+ tostr [] = ""\r
+ tostr [x] = toString x\r
+ tostr [x:xs] = toString x +++ ", " +++ tostr xs\r
+ toString (ExprRecord name xs) = "{" +++ tostr [x\\x<-:xs] +++ "}"\r
+ where\r
+ tostr [] = ""\r
+ tostr [x] = toString x\r
+ tostr [x:xs] = toString x +++ ", " +++ tostr xs\r
+ toString (ExprField name expr) = name +++ "=" +++ toString expr\r
+\r
+ \r
+:: ParseState s =\r
+ { ps_input :: !s // lex input\r
+ , ps_char :: !Maybe Char // unget char\r
+ , ps_tokens :: ![Token] // unget tokens\r
+ }\r
+\r
+lexGetChar ps=:{ps_char=Nothing, ps_input}\r
+ # (mc, ps_input) = parseInput ps_input\r
+ = (mc, {ps & ps_input = ps_input})\r
+lexGetChar ps=:{ps_char} = (ps_char, {ps & ps_char = Nothing})\r
+\r
+lexUngetChar c ps=:{ps_char=Nothing} = {ps & ps_char = Just c}\r
+lexUngetChar c ps = abort "cannot unget\n" \r
+\r
+isSpecialChar :: !Char -> Bool\r
+isSpecialChar '~' = True\r
+isSpecialChar '@' = True\r
+isSpecialChar '#' = True\r
+isSpecialChar '$' = True\r
+isSpecialChar '%' = True\r
+isSpecialChar '^' = True\r
+isSpecialChar '?' = True\r
+isSpecialChar '!' = True\r
+isSpecialChar '+' = True\r
+isSpecialChar '-' = True\r
+isSpecialChar '*' = True\r
+isSpecialChar '<' = True\r
+isSpecialChar '>' = True\r
+isSpecialChar '\\' = True\r
+isSpecialChar '/' = True\r
+isSpecialChar '|' = True\r
+isSpecialChar '&' = True\r
+isSpecialChar '=' = True\r
+isSpecialChar ':' = True\r
+isSpecialChar '.' = True\r
+isSpecialChar c = False\r
+\r
+//---------------------------------------------------------------------------------- \r
+// lex input\r
+\r
+lexUngetToken token ps=:{ps_tokens} = {ps & ps_tokens = [token:ps_tokens]}\r
+\r
+lexGetToken ps=:{ps_tokens=[token:tokens]} = (token, {ps & ps_tokens = tokens})\r
+lexGetToken ps=:{ps_tokens=[]}\r
+ = lex ps\r
+where\r
+ lex s \r
+ # (mc, s) = lexGetChar s\r
+ = case mc of\r
+ Nothing -> (TokenEnd, s)\r
+ Just '\0' -> (TokenEnd, s)\r
+ Just '(' -> (TokenOpenPar, s)\r
+ Just ')' -> (TokenClosePar, s)\r
+ Just '{' -> (TokenOpenCurly, s)\r
+ Just '}' -> (TokenCloseCurly, s)\r
+ Just '[' -> (TokenOpenList, s)\r
+ Just ']' -> (TokenCloseList, s)\r
+ Just ',' -> (TokenComma, s)\r
+ Just '\'' -> lex_char 0 [] s\r
+ Just '"' -> lex_string 0 [] s\r
+ Just '_' -> lex_ident 1 ['_'] s\r
+ Just '`' -> lex_ident 1 ['`'] s\r
+ Just '+'\r
+ # (mc, s) = lexGetChar s\r
+ -> case mc of\r
+ Nothing -> (TokenIdent "+", s)\r
+ Just c\r
+ | isDigit c\r
+ -> lex_number +1 (lexUngetChar c s)\r
+ | otherwise\r
+ -> lex_ident 1 ['+'] (lexUngetChar c s)\r
+ Just '-'\r
+ # (mc, s) = lexGetChar s\r
+ -> case mc of\r
+ Nothing -> (TokenIdent "-", s)\r
+ Just c\r
+ | isDigit c\r
+ -> lex_number -1 (lexUngetChar c s)\r
+ | otherwise\r
+ -> lex_funny_ident 1 ['-'] (lexUngetChar c s) // PK\r
+ // -> lex_ident 1 ['-'] (lexUngetChar c s)\r
+ Just c\r
+ | isSpace c\r
+ -> lex s \r
+ | isDigit c\r
+ -> lex_number +1 (lexUngetChar c s)\r
+ | isAlpha c\r
+ -> lex_ident 1 [c] s\r
+ | isSpecialChar c\r
+ -> lex_funny_ident 1 [c] s\r
+ | otherwise\r
+ -> (TokenError ("Unknown character " +++ toString c), s)\r
+\r
+ lex_digits s \r
+ = lex_digits_acc 0 [] s \r
+ lex_digits_acc num acc s\r
+ # (mc, s) = lexGetChar s\r
+ = case mc of\r
+ Nothing \r
+ -> (num, acc, s)\r
+ Just c\r
+ | isDigit c\r
+ -> lex_digits_acc (inc num) [digitToInt c:acc] s\r
+ | otherwise \r
+ -> (num, acc, lexUngetChar c s) \r
+\r
+ digits_to_int :: [Int] -> Int\r
+ digits_to_int [] = 0\r
+ digits_to_int [digit:digits] = digit + 10 * digits_to_int digits \r
+\r
+ digits_to_real :: [Int] -> Real \r
+ digits_to_real [] = 0.0\r
+ digits_to_real [digit:digits] = toReal digit + 10.0 * digits_to_real digits\r
+\r
+ lex_number sign s\r
+ #! (num_digits, digits, s) = lex_digits s\r
+ #! (mc, s) = lexGetChar s\r
+ = case mc of \r
+ Nothing -> (TokenInt (sign * digits_to_int digits), s)\r
+ Just '.'\r
+ -> lex_real_with_fraction (toReal sign) (digits_to_real digits) s\r
+ Just 'E'\r
+ #! real = toReal sign * digits_to_real digits \r
+ -> lex_real_with_exp real s\r
+ Just 'e'\r
+ #! real = toReal sign * digits_to_real digits \r
+ -> lex_real_with_exp real s\r
+ Just c \r
+ -> (TokenInt (sign * digits_to_int digits), lexUngetChar c s) \r
+\r
+ lex_real_with_fraction sign real s\r
+ #! (num_digits, digits, s) = lex_digits s\r
+ #! fraction = digits_to_real digits / 10.0^ toReal num_digits \r
+ #! real = sign * (real + fraction) \r
+ #! (mc, s) = lexGetChar s\r
+ = case mc of \r
+ Nothing -> (TokenReal real, s)\r
+ Just 'E'\r
+ -> lex_real_with_exp real s\r
+ Just 'e'\r
+ -> lex_real_with_exp real s\r
+ Just c \r
+ -> (TokenReal real, lexUngetChar c s) \r
+\r
+ lex_real_with_exp real s\r
+ # (mc, s) = lexGetChar s\r
+ = case mc of\r
+ Nothing -> (TokenReal real, s)\r
+ Just '+' \r
+ #! (num_digits, digits, s) = lex_digits s\r
+ -> (TokenReal (real * 10.0 ^ digits_to_real digits), s) \r
+ Just '-' \r
+ #! (num_digits, digits, s) = lex_digits s\r
+ -> (TokenReal (real * 10.0 ^ (-1.0 * digits_to_real digits)), s) \r
+ Just c \r
+ | isDigit c\r
+ #! (num_digits, digits, s) = lex_digits (lexUngetChar c s)\r
+ -> (TokenReal (real * 10.0 ^ digits_to_real digits), s) \r
+ | otherwise \r
+ -> (TokenError "error in real constant", s)\r
+ \r
+ lex_ident num_chars acc_chars s\r
+ # (mc, s) = lexGetChar s\r
+ = case mc of\r
+ Nothing -> (mktoken num_chars acc_chars, s)\r
+ Just '_' -> lex_ident (inc num_chars) ['_':acc_chars] s\r
+ Just '`' -> lex_ident (inc num_chars) ['`':acc_chars] s\r
+ Just c \r
+ | isAlphanum c\r
+ -> lex_ident (inc num_chars) [c:acc_chars] s\r
+ | otherwise \r
+ -> (mktoken num_chars acc_chars, lexUngetChar c s) \r
+ where\r
+ mktoken num_chars acc_chars\r
+ = case mk_str num_chars acc_chars of\r
+ "True" -> TokenBool True\r
+ "False" -> TokenBool False\r
+ str -> TokenIdent str \r
+\r
+ lex_funny_ident num_chars acc_chars s\r
+ # (mc, s) = lexGetChar s\r
+ = case mc of\r
+ Nothing -> (TokenIdent (mk_str num_chars acc_chars), s)\r
+ Just c\r
+ | isSpecialChar c\r
+ -> lex_funny_ident (inc num_chars) [c:acc_chars] s\r
+ | otherwise \r
+ -> (TokenIdent (mk_str num_chars acc_chars), lexUngetChar c s) \r
+\r
+ lex_string num_chars acc_chars s\r
+ # (mc, s) = lexGetChar s\r
+ = case mc of\r
+ Nothing -> (TokenError "error in string constant", s)\r
+ Just '"' -> (TokenString (mk_str num_chars acc_chars), s)\r
+ Just '\\' \r
+ #! (mc, s) = lex_special_char s\r
+ -> case mc of\r
+ Nothing -> (TokenError "error in string constant", s)\r
+ Just c -> lex_string (inc num_chars) [c:acc_chars] s\r
+ Just c -> lex_string (inc num_chars) [c:acc_chars] s\r
+\r
+\r
+ lex_char num_chars acc_chars s\r
+ # (mc, s) = lexGetChar s\r
+ = case mc of\r
+ Nothing -> (TokenError "error in char constant", s)\r
+ Just '\'' \r
+ | num_chars == 1\r
+ -> (TokenChar (hd acc_chars), s)\r
+ | num_chars == 0\r
+ -> (TokenError "char constant contains no characters ", s)\r
+ | otherwise \r
+ -> (TokenError "char constant contains more than one character", s)\r
+ Just '\\' \r
+ #! (mc, s) = lex_special_char s\r
+ -> case mc of\r
+ Nothing -> (TokenError "error in char constant", s)\r
+ Just c -> lex_char (inc num_chars) [c:acc_chars] s\r
+ Just c -> lex_char (inc num_chars) [c:acc_chars] s\r
+\r
+ lex_special_char s \r
+ #! (mc, s) = lexGetChar s\r
+ = case mc of\r
+ Just 'n' -> (Just '\n', s)\r
+ Just 'r' -> (Just '\r', s)\r
+ Just 'f' -> (Just '\f', s)\r
+ Just 'b' -> (Just '\b', s)\r
+ Just 't' -> (Just '\t', s)\r
+ Just '\\' -> (Just '\\', s)\r
+ Just '\'' -> (Just '\'', s)\r
+ Just '\"' -> (Just '\"', s)\r
+ Just '\0' -> (Just '\0', s)\r
+ //Just '\x' -> abort "lex: hex char not implemented\n"\r
+ //Just '\0' -> abort "lex: oct char not implemented\n"\r
+ _ -> (mc, s)\r
+\r
+ mk_str num_chars acc_chars\r
+ # str = createArray num_chars ' '\r
+ = fill (dec num_chars) acc_chars str\r
+ where \r
+ fill i [] str = str\r
+ fill i [x:xs] str = fill (dec i) xs {str & [i] = x}\r
+ \r
+\r
+//---------------------------------------------------------------------------------- \r
+// preparse input\r
+\r
+\r
+:: ParseEnv = PETop | PETuple | PEPar | PERecord | PEList\r
+\r
+preParse :: (ParseState s) -> (Expr, ParseState s) | ParseInput s\r
+preParse s \r
+ = parse_expr PETop s\r
+where\r
+ parse_expr env s\r
+ = parse_app env [] s\r
+ \r
+ parse_app env exprs s\r
+ #! (token, s) = lexGetToken s\r
+ = parse token env exprs s\r
+ where\r
+ parse TokenComma PETuple exprs s = (mkexpr exprs, lexUngetToken TokenComma s)\r
+ parse TokenComma PERecord exprs s = (mkexpr exprs, lexUngetToken TokenComma s)\r
+ parse TokenComma PEList exprs s = (mkexpr exprs, lexUngetToken TokenComma s)\r
+ parse TokenComma PETop exprs s = (ExprError "end of input expected instead of ,", s)\r
+ parse TokenComma PEPar exprs s = (ExprError ") expected instead of ,", s)\r
+ parse TokenComma env exprs s = abort "unknown env\n"\r
+\r
+ parse TokenClosePar PETuple exprs s = (mkexpr exprs, lexUngetToken TokenClosePar s)\r
+ parse TokenClosePar PERecord exprs s = (ExprError "} expected instead of )", s)\r
+ parse TokenClosePar PEList exprs s = (ExprError "] expected instead of )", s)\r
+ parse TokenClosePar PETop exprs s = (ExprError "end of input expected instead of )", s)\r
+ parse TokenClosePar PEPar exprs s = (mkexpr exprs, lexUngetToken TokenClosePar s)\r
+ parse TokenClosePar env exprs s = abort "unknown env\n"\r
+\r
+ parse TokenCloseCurly PETuple exprs s = (ExprError ") expected instead of }", s)\r
+ parse TokenCloseCurly PEList exprs s = (ExprError "] expected instead of }", s)\r
+ parse TokenCloseCurly PERecord exprs s = (mkexpr exprs, lexUngetToken TokenCloseCurly s)\r
+ parse TokenCloseCurly PETop exprs s = (ExprError "end of input expected instead of )", s)\r
+ parse TokenCloseCurly PEPar exprs s = (mkexpr exprs, lexUngetToken TokenCloseCurly s)\r
+ parse TokenCloseCurly env exprs s = abort "unknown env\n"\r
+\r
+ parse TokenCloseList PETuple exprs s = (ExprError ") expected instead of ]", s)\r
+ parse TokenCloseList PERecord exprs s = (ExprError "} expected instead of ]", s)\r
+ parse TokenCloseList PEList exprs s = (mkexpr exprs, lexUngetToken TokenCloseList s)\r
+ parse TokenCloseList PETop exprs s = (ExprError "end of input expected instead of )", s)\r
+ parse TokenCloseList PEPar exprs s = (mkexpr exprs, lexUngetToken TokenCloseList s)\r
+ parse TokenCloseList env exprs s = abort "unknown env\n"\r
+\r
+ parse TokenEnd PETuple exprs s = (ExprError ") or, expected instead of end of input", s)\r
+ parse TokenEnd PERecord exprs s = (ExprError "} or, expected instead of end of input", s)\r
+ parse TokenEnd PEList exprs s = (ExprError "] or, expected instead of end of input", s)\r
+ parse TokenEnd PETop exprs s = (mkexpr exprs, lexUngetToken TokenEnd s)\r
+ parse TokenEnd PEPar exprs s = (ExprError ") expected instead of end of input",s)\r
+ parse TokenEnd env exprs s = abort "unknown env\n"\r
+ \r
+ parse (TokenInt x) env exprs s = parse_app env [ExprInt x:exprs] s\r
+ parse (TokenBool x) env exprs s = parse_app env [ExprBool x:exprs] s\r
+ parse (TokenReal x) env exprs s = parse_app env [ExprReal x:exprs] s\r
+ parse (TokenChar x) env exprs s = parse_app env [ExprChar x:exprs] s\r
+ parse (TokenString x) env exprs s = parse_app env [ExprString x:exprs] s\r
+ parse (TokenIdent x) env exprs s = parse_app env [ExprIdent x:exprs] s\r
+ parse TokenOpenPar env exprs s \r
+ # (expr, s) = parse_par_expr s\r
+ = case expr of\r
+ ExprError err -> (ExprError err, s)\r
+ _ -> parse_app env [expr:exprs] s\r
+ parse TokenOpenCurly env exprs s\r
+ # (expr, s) = parse_record_or_array s\r
+ = case expr of\r
+ ExprError err -> (ExprError err, s)\r
+ _ -> parse_app env [expr:exprs] s\r
+ parse TokenOpenList env exprs s \r
+ # (expr, s) = parse_list s\r
+ = case expr of\r
+ ExprError err -> (ExprError err, s)\r
+ _ -> parse_app env [expr:exprs] s\r
+ parse (TokenError err) env exprs s \r
+ = (ExprError ("lex error in parse_app: " +++ err), s) \r
+ \r
+ parse token env exprs s \r
+ = abort ("parse app - unknown token " +++ toString token)\r
+ \r
+ \r
+ mkexpr [] = ExprError "expression expected"\r
+ mkexpr [expr] = expr\r
+ mkexpr exprs = ExprApp {e\\e <- reverse exprs}\r
+\r
+ parse_par_expr s\r
+ #! (expr, s) = parse_expr PETuple s\r
+ = case expr of\r
+ ExprError err -> (ExprError err, s)\r
+ _\r
+ #! (token, s) = lexGetToken s\r
+ -> case token of\r
+ TokenClosePar -> (expr, s)\r
+ TokenComma -> parse_tuple [expr] (lexUngetToken token s)\r
+ _ -> (ExprError (", or ) expected, found " +++ toString token), s)\r
+ \r
+ parse_tuple exprs s \r
+ #! (token, s) = lexGetToken s\r
+ = case token of\r
+ TokenComma \r
+ #! (expr, s) = parse_expr PETuple s\r
+ -> case expr of\r
+ ExprError err -> (ExprError err, s)\r
+ _ -> parse_tuple [expr:exprs] s\r
+ TokenClosePar \r
+ -> (ExprTuple {e\\e<-reverse exprs}, s)\r
+ _ \r
+ -> (ExprError "parse tuple: , or ) expected", s) \r
+\r
+ parse_list s\r
+ #! (token, s) = lexGetToken s\r
+ = case token of\r
+ TokenCloseList \r
+ -> (ExprList [], s)\r
+ _ \r
+ #! (expr, s) = parse_expr PEList (lexUngetToken token s)\r
+ -> case expr of\r
+ ExprError err -> (ExprError (err +++ " ; parse list"), s)\r
+ _ -> parse_rest [expr] s\r
+ where\r
+ parse_rest exprs s \r
+ #! (token, s) = lexGetToken s\r
+ = case token of\r
+ TokenComma \r
+ #! (expr, s) = parse_expr PEList s\r
+ -> case expr of\r
+ ExprError err -> (ExprError err, s)\r
+ _ -> parse_rest [expr:exprs] s\r
+ TokenCloseList \r
+ -> (ExprList (reverse exprs), s)\r
+ _ \r
+ -> (ExprError "parse list: , or ] expected", s) \r
+\r
+ \r
+ parse_record_or_array s \r
+ #! (token, s) = lexGetToken s\r
+ = case token of\r
+ TokenCloseCurly \r
+ -> (ExprArray [], s)\r
+ TokenIdent name\r
+ #! (token, s) = lexGetToken s\r
+ -> case token of\r
+ TokenIdent "="\r
+ #! (expr, s) = parse_expr PERecord s\r
+ -> parse_record Nothing [ExprField name expr] s\r
+ TokenIdent "|"\r
+ -> parse_record (Just ("_" +++ name)) [] (lexUngetToken TokenComma s)\r
+ _\r
+ #! (expr, s) = parse_expr PERecord \r
+ (lexUngetToken (TokenIdent name) (lexUngetToken token s))\r
+ -> parse_array [expr] s\r
+ _ \r
+ #! (expr, s) = parse_expr PERecord (lexUngetToken token s)\r
+ -> parse_array [expr] s\r
+ where\r
+ parse_record rec_name fields s\r
+ #! (token, s) = lexGetToken s\r
+ = case token of\r
+ TokenCloseCurly \r
+ -> (ExprRecord rec_name {e\\e<- reverse fields}, s)\r
+ TokenComma\r
+ #! (token, s) = lexGetToken s\r
+ -> case token of\r
+ TokenIdent field_name\r
+ #! (token, s) = lexGetToken s\r
+ -> case token of\r
+ TokenIdent "=" \r
+ #! (expr, s) = parse_expr PERecord s\r
+ -> parse_record rec_name [ExprField field_name expr:fields] s\r
+ _ -> (ExprError ("parse record failed on token " +++ toString token), s) \r
+\r
+ parse_array exprs s\r
+ #! (token, s) = lexGetToken s\r
+ = case token of\r
+ TokenCloseCurly \r
+ -> (ExprArray (reverse exprs), s)\r
+ TokenComma\r
+ #! (expr, s) = parse_expr PERecord s\r
+ -> parse_array [expr:exprs] s\r
+ _ -> (ExprError ("parse array failed on token " +++ toString token), s) \r
+\r
+\r
+//---------------------------------------------------------------------------------- \r
+\r
+generic gParse a :: Expr -> Maybe a\r
+\r
+gParse{|Int|} (ExprInt x) = Just x \r
+gParse{|Int|} _ = Nothing\r
+\r
+gParse{|Char|} (ExprChar x) = Just x \r
+gParse{|Char|} _ = Nothing\r
+\r
+gParse{|Bool|} (ExprBool x) = Just x \r
+gParse{|Bool|} _ = Nothing\r
+\r
+gParse{|Real|} (ExprReal x) = Just x \r
+gParse{|Real|} _ = Nothing\r
+\r
+gParse{|String|} (ExprString x) = Just x\r
+gParse{|String|} _ = Nothing \r
+\r
+gParse{|UNIT|} ExprUnit = Just UNIT\r
+gParse{|UNIT|} _ = Nothing \r
+\r
+gParse{|PAIR|} fx fy (ExprPair ex ey) \r
+ = case fx ex of\r
+ Just x -> case fy ey of\r
+ Just y -> Just (PAIR x y)\r
+ Nothing -> Nothing\r
+ Nothing -> Nothing\r
+gParse{|PAIR|} fx fy _ = Nothing\r
+\r
+gParse{|EITHER|} fl fr expr \r
+ = case fl expr of\r
+ Nothing -> case fr expr of\r
+ Nothing -> Nothing\r
+ Just x -> Just (RIGHT x)\r
+ Just x -> Just (LEFT x) \r
+ \r
+gParse{|CONS of d|} parse_arg expr\r
+ | d.gcd_arity == 0 \r
+ = parse_nullary expr\r
+ | isEmpty d.gcd_fields\r
+ | is_tuple d.gcd_name\r
+ = parse_tuple expr \r
+ | otherwise\r
+ = case d.gcd_prio of\r
+ GenConsNoPrio \r
+ -> parse_nonfix expr\r
+ GenConsPrio assoc prio \r
+ -> parse_infix assoc prio expr \r
+ | otherwise\r
+ = parse_record expr \r
+where\r
+ mkprod [] = abort "mkprod\n"\r
+ mkprod [expr] = expr\r
+ mkprod exprs \r
+ # (xs, ys) = splitAt (length exprs / 2) exprs\r
+ = ExprPair (mkprod xs) (mkprod ys) \r
+ \r
+ parse_nullary (ExprIdent name)\r
+ | name == d.gcd_name\r
+ = mapMaybe CONS (parse_arg ExprUnit)\r
+ parse_nullary _\r
+ = Nothing\r
+\r
+ parse_nonfix (ExprApp exprs)\r
+ = parse_nonfix1 exprs\r
+ parse_nonfix (ExprAppInInfix exprs _ _ _)\r
+ = parse_nonfix1 exprs\r
+ parse_nonfix _ \r
+ = Nothing\r
+\r
+ parse_nonfix1 exprs\r
+ #! size_exprs = size exprs\r
+ | size_exprs == d.gcd_arity + 1 && is_ident d.gcd_name exprs.[0]\r
+ #! arg_exprs = [exprs.[i] \\ i <- [1 .. size_exprs - 1]]\r
+ = mapMaybe CONS (parse_arg (mkprod arg_exprs))\r
+ | otherwise\r
+ = Nothing\r
+ \r
+ is_ident wanted_name (ExprIdent name) = name == wanted_name\r
+ is_ident _ _ = False \r
+\r
+ parse_tuple (ExprTuple exprs) \r
+ = mapMaybe CONS (parse_arg (mkprod [e\\e<-:exprs]))\r
+ parse_tuple expr = Nothing\r
+ \r
+ parse_record (ExprRecord rec_name exprs) \r
+ | check_name rec_name d.gcd_name\r
+ = mapMaybe CONS (parse_arg (mkprod [e\\e<-:exprs]))\r
+ = Nothing\r
+ where\r
+ check_name Nothing cons_name = True\r
+ check_name (Just rec_name) cons_name = rec_name == cons_name\r
+ parse_record expr = Nothing\r
+\r
+ parse_infix this_assoc this_prio (ExprApp exprs)\r
+ = parse_infix1 this_assoc this_prio exprs\r
+ parse_infix this_assoc this_prio (ExprAppInInfix exprs outer_assoc outer_prio branch)\r
+ | this_prio > outer_prio\r
+ = parse_infix1 this_assoc this_prio exprs\r
+ | this_prio < outer_prio\r
+ = Nothing\r
+ | otherwise\r
+ = case (this_assoc, outer_assoc, branch) of\r
+ (GenConsAssocLeft, GenConsAssocLeft, GenConsAssocLeft)\r
+ -> parse_infix1 this_assoc this_prio exprs\r
+ (GenConsAssocRight, GenConsAssocRight, GenConsAssocRight)\r
+ -> parse_infix1 this_assoc this_prio exprs\r
+ _ -> Nothing\r
+ parse_infix this_assoc this_prio expr\r
+ = Nothing\r
+ \r
+ parse_infix1 this_assoc this_prio exprs\r
+ #! size_exprs = size exprs\r
+ | size_exprs < 3 = Nothing\r
+ = case (case this_assoc of GenConsAssocLeft -> find_last; _ -> find_first) exprs of\r
+ Nothing -> Nothing\r
+ Just op_index\r
+ #! left_arg = mkarg GenConsAssocLeft {exprs.[i] \\ i <- [0 .. op_index - 1]}\r
+ #! right_arg = mkarg GenConsAssocRight {exprs.[i] \\ i <- [op_index + 1 .. size_exprs - 1]}\r
+ -> mapMaybe CONS (parse_arg (ExprPair left_arg right_arg))\r
+ where\r
+ mkarg branch exprs\r
+ = case size exprs of\r
+ 0 -> abort "mkarg\n"\r
+ 1 -> exprs.[0]\r
+ _ -> ExprAppInInfix exprs this_assoc this_prio branch\r
+ \r
+ find_last exprs \r
+ = find (size exprs - 2) exprs\r
+ where\r
+ find i exprs\r
+ | i < 1\r
+ = Nothing\r
+ | otherwise \r
+ = case exprs.[i] of\r
+ ExprIdent s | s == d.gcd_name -> Just i \r
+ _ -> find (dec i) exprs \r
+ find_first exprs\r
+ = find 1 exprs\r
+ where\r
+ find i exprs\r
+ | i >= size exprs - 1\r
+ = Nothing\r
+ | otherwise \r
+ = case exprs.[i] of\r
+ ExprIdent s | s == d.gcd_name -> Just i \r
+ _ -> find (inc i) exprs \r
+\r
+ is_tuple name \r
+ #! size_name = size name\r
+ = (size_name == 7 || size_name == 8)\r
+ && name.[0] == '_'\r
+ && name.[1] == 'T'\r
+ && name.[2] == 'u'\r
+ && name.[3] == 'p'\r
+ && name.[4] == 'l'\r
+ && name.[5] == 'e'\r
+ && isDigit name.[6]\r
+ && (size_name == 7 || isDigit name.[7])\r
+\r
+gParse{|FIELD of d|} parse_arg (ExprField name value) \r
+ | d.gfd_name == name\r
+ = mapMaybe FIELD (parse_arg value)\r
+ = Nothing\r
+gParse{|OBJECT|} parse_arg expr\r
+ = mapMaybe OBJECT (parse_arg expr)\r
+\r
+gParse{|[]|} parse_arg (ExprList exprs) \r
+ = maybeAll (map parse_arg exprs)\r
+gParse{|[]|} parse_arg _ = Nothing\r
+\r
+gParse{|{}|} parse_arg (ExprArray exprs)\r
+ = mapMaybe (\xs -> {x\\x<-xs}) (maybeAll (map parse_arg exprs)) \r
+gParse{|{}|} parse_arg _ = Nothing\r
+ \r
+gParse{|{!}|} parse_arg (ExprArray exprs)\r
+ = mapMaybe (\xs -> {x\\x<-xs}) (maybeAll (map parse_arg exprs))\r
+gParse{|{!}|} parse_arg _ = Nothing\r
+\r
+maybeAll [] = Just []\r
+maybeAll [Nothing:_] = Nothing\r
+maybeAll [Just x: mxs] \r
+ = case maybeAll mxs of\r
+ Nothing -> Nothing\r
+ Just xs -> Just [x:xs] \r
+\r
+//---------------------------------------------------------------------------------- \r
+\r
+preParseInput :: s -> Expr | ParseInput s\r
+preParseInput input \r
+ # (expr, s) = preParse {ps_input=input, ps_char = Nothing, ps_tokens = [] }\r
+ = expr\r
+ \r
+preParseString :: String -> Expr\r
+preParseString str = preParseInput {si_pos = 0, si_str = str}\r
+\r
+preParseFile :: File -> Expr \r
+preParseFile file = preParseInput file\r
+\r
+parseString :: String -> Maybe a | gParse{|*|} a\r
+parseString str = gParse{|*|} (preParseString str)\r
+\r
+parseFile :: File -> Maybe a | gParse{|*|} a\r
+parseFile file = gParse{|*|} (preParseFile file)\r
+\r
+//Start = preParseString "{rec_field = A (B1, B2) (C D), rec_field2 = (X,Y)}"\r
+//Start = preParseString "123.456e1"\r
+//Start = preParseString "([1,2,3], [4,5,6])"\r
+//Start = preParseString "{A B D,X Y Z,I J K}"\r
+\r
+//---------------------------------------------------------------------------------- \r
+\r
+:: Tree a b = Tip a | Bin b (Tree a b) (Tree a b)\r
+:: T\r
+ = :+: infixl 2 T T\r
+ | :-: infixl 2 T T\r
+ | :*: infixl 3 T T\r
+ | :->: infixr 4 T T\r
+ | U\r
+\r
+:: Rec = { rec_x :: T, rec_y :: (.Tree Int Real, Real) }\r
+\r
+derive gParse (,), (,,), (,,,), Tree, T, Rec\r
+derive bimap Maybe, ParseState, []\r
+\r
+//Start :: Maybe T\r
+//Start = parseString "U :+: U :+: U"\r
+\r
+//Start :: Maybe (Tree Int Int)\r
+//Start = parseString "Bin 1 (Tip 2) (Tip 3)"\r
+\r
+//Start :: Maybe (Tree Int Int, Int)\r
+//Start = parseString "((Bin 1 (Tip (2)) (Tip 3), 1000))"\r
+\r
+//Start :: Maybe Rec\r
+//Start = parseString "{ Rec | rec_x = U :+: U :+: U, rec_y = (Bin 1.1 (Tip 2) (Tip 3), 1.09) }"\r
+\r
+//Start :: Maybe [Tree Int Int]\r
+//Start = parseString "[Bin 1 (Tip (2)) (Tip 3), Tip 100, Tip 200]" \r
+\r
+//Start = preParseString "1.23e12"\r
+\r
+/*\r
+Start :: *World -> (Maybe Rec, *World)\r
+Start w \r
+ #! (ok, f, w) = sfopen "test.txt" FReadText w\r
+ | not ok\r
+ = (abort "sfopen failed", w)\r
+ = (parseFile f, w) \r
+*/
\ No newline at end of file
--- /dev/null
+definition module GenPrint\r
+\r
+import StdGeneric\r
+\r
+class PrintOutput s where\r
+ printOutput :: Char *s -> *s\r
+ \r
+:: *StringOutput\r
+\r
+:: PrintState s\r
+\r
+mkPrintState :: *s -> PrintState *s | PrintOutput s\r
+mkStringPrintState :: PrintState StringOutput\r
+printToString :: a -> String | gPrint{|*|} a\r
+\r
+(<<-) infixl 0 :: (PrintState *s) a -> *(PrintState *s) \r
+ | gPrint{|*|} a & PrintOutput s\r
+\r
+\r
+instance PrintOutput StringOutput \r
+instance PrintOutput File\r
+\r
+generic gPrint a :: a (PrintState *s) -> (PrintState *s) | PrintOutput s\r
+\r
+derive gPrint Int, Real, Char, Bool, String, UNIT, PAIR, EITHER, FIELD, CONS, OBJECT, [], {!}, {}\r
+//derive bimap PrintState\r
+\r
--- /dev/null
+implementation module GenPrint\r
+\r
+import StdGeneric, StdEnv, StdMaybe\r
+\r
+//-------------------------------------------------------------------------------------\r
+\r
+:: *StringOutput = {so_str :: !*String, so_pos :: !Int}\r
+\r
+\r
+instance PrintOutput StringOutput where\r
+ printOutput ch s=:{so_str, so_pos} \r
+ #! new_str = realloc_if_needed so_pos so_str \r
+ = {s & so_str = {new_str & [so_pos] = ch}, so_pos = inc so_pos}\r
+ where\r
+ realloc_if_needed :: Int u:String -> v:String, [u <= v]\r
+ realloc_if_needed pos str\r
+ #! size_str = size str\r
+ | pos == size_str\r
+ #! new_str = createArray ((size_str + 1) * 3 /2) '\0'\r
+ #! (new_str, str) = fill 0 size_str new_str str\r
+ = new_str\r
+ | otherwise \r
+ = str \r
+ fill i n new_str str \r
+ | i == n\r
+ = (new_str, str)\r
+ | otherwise \r
+ #! (ch, str) = str![i] \r
+ = fill (inc i) n {new_str & [i] = ch} str \r
+ \r
+instance PrintOutput File where\r
+ printOutput x s\r
+ = fwritec x s\r
+\r
+\r
+//-------------------------------------------------------------------------------------\r
+\r
+\r
+($) infixl 9\r
+($) x y = y o x\r
+\r
+(@) infix 8 \r
+(@) x y = x y\r
+\r
+mapSt f [] st = ([], st)\r
+mapSt f [x:xs] st\r
+ # (y, st) = f x st\r
+ # (ys, st) = mapSt f xs st\r
+ = ([y:ys], st)\r
+\r
+foldSt f [] = id \r
+foldSt f [x:xs] = foldSt f xs o f x\r
+\r
+//-------------------------------------------------------------------------------------\r
+:: PrintState s =\r
+ { ps_output :: !s\r
+ , ps_context :: !Context\r
+ }\r
+:: Context \r
+ = CtxNone // initial env\r
+ | CtxNullary // nullary constructor\r
+ | CtxRecord // record constructor \r
+ | CtxTuple // tuple constructor\r
+ | CtxNonfix // normal nonfix constructor\r
+ | CtxInfix // infix constructor\r
+ String // name\r
+ GenConsAssoc // constructor's associativity \r
+ Prio // constructors priority \r
+ GenConsAssoc // left or right argument\r
+:: Prio :== Int\r
+ \r
+instance == GenConsAssoc where\r
+ (==) GenConsAssocNone GenConsAssocNone = True\r
+ (==) GenConsAssocLeft GenConsAssocLeft = True\r
+ (==) GenConsAssocRight GenConsAssocRight = True\r
+ (==) _ _ = False\r
+\r
+mkContext :: GenericConsDescriptor -> Context\r
+mkContext {gcd_prio=GenConsNoPrio, gcd_fields, gcd_name, gcd_arity}\r
+ | isEmpty gcd_fields \r
+ | gcd_arity == 0\r
+ = CtxNullary\r
+ | is_tuple gcd_name\r
+ = CtxTuple\r
+ | otherwise\r
+ = CtxNonfix\r
+ | otherwise \r
+ = CtxRecord \r
+where\r
+ is_tuple name \r
+ #! size_name = size name\r
+ = (size_name == 7 || size_name == 8)\r
+ && name.[0] == '_'\r
+ && name.[1] == 'T'\r
+ && name.[2] == 'u'\r
+ && name.[3] == 'p'\r
+ && name.[4] == 'l'\r
+ && name.[5] == 'e'\r
+ && isDigit name.[6]\r
+ && (size_name == 7 || isDigit name.[7])\r
+ \r
+mkContext {gcd_prio=GenConsPrio assoc prio, gcd_name} \r
+ = CtxInfix gcd_name assoc prio GenConsAssocNone\r
+\r
+needParenthesis :: Context Context -> Bool\r
+needParenthesis CtxNone outer_ctx = abort "needParenthesis: this_ctx = CtxNone"\r
+needParenthesis this_ctx CtxNullary = abort "needParenthesis: outer_ctx = CtxNullary"\r
+needParenthesis CtxNullary outer_ctx = False\r
+needParenthesis CtxTuple outer_ctx = True // the tuple parenthesis\r
+needParenthesis CtxRecord outer_ctx = False\r
+needParenthesis CtxNonfix CtxNone = False\r
+needParenthesis CtxNonfix CtxTuple = False\r
+needParenthesis CtxNonfix CtxRecord = False\r
+needParenthesis CtxNonfix CtxNonfix = True\r
+needParenthesis CtxNonfix (CtxInfix _ _ _ _) = False\r
+needParenthesis (CtxInfix _ _ _ _) CtxNone = False\r
+needParenthesis (CtxInfix _ _ _ _) CtxNullary = True\r
+needParenthesis (CtxInfix _ _ _ _) CtxTuple = False\r
+needParenthesis (CtxInfix _ _ _ _) CtxRecord = False\r
+needParenthesis (CtxInfix _ _ _ _) CtxNonfix = True // False // PK\r
+needParenthesis (CtxInfix _ this_assoc this_prio _) (CtxInfix _ outer_assoc outer_prio branch) \r
+ = outer_prio > this_prio \r
+ || (outer_prio == this_prio && not (this_assoc == outer_assoc && this_assoc == branch))\r
+\r
+//derive bimap PrintState\r
+\r
+//-------------------------------------------------------------------------------------\r
+\r
+\r
+printChar :: Char (PrintState *s) -> (PrintState *s) | PrintOutput s \r
+printChar ch s=:{ps_output}\r
+ # ps_output = printOutput ch ps_output\r
+ = {s & ps_output = ps_output}\r
+\r
+printCharLiteral '\\' = printChar '\\' $ printChar '\\'\r
+printCharLiteral '\n' = printChar '\\' $ printChar '\n'\r
+printCharLiteral '\t' = printChar '\\' $ printChar '\t'\r
+printCharLiteral '\b' = printChar '\\' $ printChar '\b'\r
+printCharLiteral '\'' = printChar '\\' $ printChar '\''\r
+printCharLiteral '\"' = printChar '\\' $ printChar '\"'\r
+printCharLiteral '\0' = printChar '\\' $ printChar '\0'\r
+printCharLiteral c = printChar c\r
+\r
+printString str\r
+ #! size_str = size str\r
+ = do_it 0 size_str str\r
+where\r
+ do_it i n str\r
+ | i == n\r
+ = id\r
+ = printChar str.[i]\r
+ $ do_it (inc i) n str \r
+\r
+printStringLiteral str\r
+ #! size_str = size str\r
+ = do_it 0 size_str str\r
+where\r
+ do_it i n str\r
+ | i == n\r
+ = id\r
+ = printCharLiteral str.[i]\r
+ $ do_it (inc i) n str \r
+\r
+\r
+printList f xs ps=:{ps_context}\r
+ = { print_list f xs { ps & ps_context = CtxNone} \r
+ & ps_context = ps_context \r
+ }\r
+where\r
+ print_list f [] = id\r
+ print_list f [x] = f x\r
+ print_list f [x:xs] \r
+ = f x \r
+ $ printString ", "\r
+ $ print_list f xs \r
+\r
+//-------------------------------------------------------------------------------------\r
+generic gPrint a :: a (PrintState *s) -> (PrintState *s) | PrintOutput s\r
+gPrint{|Int|} x st \r
+ = printString (toString x) st\r
+gPrint{|Real|} x st \r
+ # str = toString x\r
+ | all isDigit [c\\c<-:str] // add .0 if needed\r
+ = printString (str +++ ".0") st \r
+ | str.[0] == '.'\r
+ = printString ("0" +++ str) st\r
+ | otherwise \r
+ = printString str st\r
+gPrint{|Bool|} x st \r
+ = printString (toString x) st\r
+gPrint{|Char|} x st \r
+ = printChar '\'' $ printCharLiteral x $ printChar '\'' @ st \r
+gPrint{|String|} x st \r
+ = printChar '"'\r
+ $ printStringLiteral x \r
+ $ printChar '"'\r
+ @ st\r
+gPrint{|UNIT|} x st \r
+ = st\r
+ \r
+gPrint{|EITHER|} fl fr (LEFT x) st = fl x st\r
+gPrint{|EITHER|} fl fr (RIGHT x) st = fr x st\r
+\r
+gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxNone}\r
+ = abort "gOutput{|PAIR|}: CtxNone\n" \r
+gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxNullary}\r
+ = abort "gOutput{|PAIR|}: CtxNullary\n" \r
+gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxTuple}\r
+ = fx x $ printString ", " $ fy y @ st\r
+gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxRecord}\r
+ = fx x $ printString ", " $ fy y @ st\r
+gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxNonfix}\r
+ = fx x $ printChar ' ' $ fy y @ st \r
+gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxInfix name assoc prio branch} \r
+ # st = fx x {st & ps_context = CtxInfix name assoc prio GenConsAssocLeft} \r
+ # st = printChar ' ' $ printStringLiteral name $ printChar ' ' @ st\r
+ # st = fy y {st & ps_context = CtxInfix name assoc prio GenConsAssocRight} \r
+ = {st & ps_context = CtxInfix name assoc prio branch} \r
+\r
+gPrint{|CONS of d|} print_arg (CONS x) st=:{ps_context}\r
+ #! ctx = mkContext d\r
+ #! st = { st & ps_context = ctx }\r
+ | needParenthesis ctx ps_context\r
+ = { printChar '(' \r
+ $ print print_arg ctx \r
+ $ printChar ')' \r
+ @ st \r
+ & ps_context = ps_context \r
+ }\r
+ | otherwise\r
+ = { print print_arg ctx st & ps_context = ps_context }\r
+where\r
+ print print_arg CtxNone \r
+ = abort "gOutput{|CONS|}: CtxNone\n"\r
+ print print_arg CtxNullary \r
+ = printStringLiteral d.gcd_name \r
+ print print_arg CtxTuple\r
+ = print_arg x\r
+ print print_arg CtxRecord \r
+ = printString "{ " \r
+ $ foldSt printChar (tl [c\\c<-:d.gcd_name]) //printStringLiteral d.gcd_name \r
+ $ printString " | "\r
+ $ print_arg x\r
+ $ printString " }"\r
+ print print_arg CtxNonfix \r
+ = printStringLiteral d.gcd_name\r
+ $ printChar ' '\r
+ $ print_arg x \r
+ print print_arg (CtxInfix _ _ _ _) \r
+ = print_arg x\r
+\r
+gPrint{|FIELD of d|} f (FIELD x) st\r
+ = printStringLiteral d.gfd_name\r
+ $ printString " = " \r
+ $ f x \r
+ @ st\r
+gPrint{|OBJECT|} f (OBJECT x) st\r
+ = f x st \r
+ \r
+gPrint{|[]|} f xs st\r
+ = printChar '['\r
+ $ printList f xs \r
+ $ printChar ']'\r
+ @ st\r
+\r
+gPrint{|{}|} f xs st\r
+ = printChar '{'\r
+ $ printList f [ x \\ x <-: xs] \r
+ $ printChar '}'\r
+ @ st\r
+\r
+gPrint{|{!}|} f xs st\r
+ = printChar '{'\r
+ $ printList f [ x \\ x <-: xs] \r
+ $ printChar '}'\r
+ @ st\r
+\r
+//derive gOutput (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+ \r
+//-------------------------------------------------------------------------------------\r
+(<<-) infixl 0 :: (PrintState *s) a -> *(PrintState *s) | gPrint{|*|} a & PrintOutput s\r
+(<<-) s x = gPrint{|*|} x s\r
+\r
+mkPrintState :: *s -> PrintState *s | PrintOutput s\r
+mkPrintState s =\r
+ { ps_output = s\r
+ , ps_context = CtxNone\r
+ } \r
+\r
+mkStringPrintState :: PrintState StringOutput\r
+mkStringPrintState = mkPrintState {so_pos = 0, so_str = createArray 16 '\0'}\r
+\r
+openFilePrintState :: String *fs -> (Maybe (PrintState *File), *fs) | FileSystem fs\r
+openFilePrintState name fs \r
+ # (ok, file, fs) = fopen name FWriteText fs\r
+ | ok = (Just (mkPrintState file), fs)\r
+ = (Nothing, fs)\r
+\r
+printToString :: a -> String | gPrint{|*|} a\r
+printToString x\r
+ # string_output = (mkStringPrintState <<- x).ps_output\r
+ = string_output.so_str % (0,string_output.so_pos-1)\r
+\r
+//-------------------------------------------------------------------------------------\r
+\r
+//Start = 1
\ No newline at end of file
--- /dev/null
+definition module GenReduce\r
+\r
+import StdGeneric\r
+\r
+generic gReduce t :: (a a -> a) a t -> a\r
+derive gReduce c, PAIR, EITHER, CONS, FIELD, OBJECT\r
+derive gReduce [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+generic gReduceRSt t :: .t .st -> .st\r
+derive gReduceRSt c, PAIR, EITHER, CONS, FIELD, OBJECT\r
+derive gReduceRSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+generic gReduceLSt t :: .t .st -> .st\r
+derive gReduceLSt c, PAIR, EITHER, CONS, FIELD, OBJECT\r
+derive gReduceLSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+
\ No newline at end of file
--- /dev/null
+implementation module GenReduce\r
+\r
+import StdGeneric, _Array\r
+\r
+// or crush\r
+generic gReduce t :: (a a -> a) a t -> a\r
+gReduce{|c|} op e x = e\r
+gReduce{|PAIR|} fx fy op e (PAIR x y) = op (fx op e x) (fy op e y)\r
+gReduce{|EITHER|} fl fr op e (LEFT x) = fl op e x\r
+gReduce{|EITHER|} fl fr op e (RIGHT x) = fr op e x\r
+gReduce{|CONS|} f op e (CONS x) = f op e x \r
+gReduce{|FIELD|} f op e (FIELD x) = f op e x\r
+gReduce{|OBJECT|} f op e (OBJECT x) = f op e x\r
+gReduce{|{}|} f op e x = reduceArray f op e x\r
+gReduce{|{!}|} f op e x = reduceArray f op e x\r
+derive gReduce [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+generic gReduceRSt t :: .t .st -> .st\r
+gReduceRSt{|c|} x st = st\r
+gReduceRSt{|PAIR|} fx fy (PAIR x y) st = fx x (fy y st)\r
+gReduceRSt{|EITHER|} fl fr x st = reduceEITHER fl fr x st\r
+gReduceRSt{|CONS|} f (CONS x) st = f x st\r
+gReduceRSt{|FIELD|} f (FIELD x) st = f x st\r
+gReduceRSt{|OBJECT|} f (OBJECT x) st = f x st\r
+gReduceRSt{|{}|} f xs st = reduceArrayRSt f xs st \r
+gReduceRSt{|{!}|} f xs st = reduceArrayRSt f xs st \r
+derive gReduceRSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+generic gReduceLSt t :: .t .st -> .st\r
+gReduceLSt{|c|} x st = st\r
+gReduceLSt{|PAIR|} fx fy (PAIR x y) st = fy y (fx x st)\r
+gReduceLSt{|EITHER|} fl fr x st = reduceEITHER fl fr x st\r
+gReduceLSt{|CONS|} f (CONS x) st = f x st\r
+gReduceLSt{|FIELD|} f (FIELD x) st = f x st\r
+gReduceLSt{|OBJECT|} f (OBJECT x) st = f x st\r
+gReduceLSt{|{}|} f xs st = reduceArrayLSt f xs st \r
+gReduceLSt{|{!}|} f xs st = reduceArrayLSt f xs st \r
+derive gReduceLSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+reduceEITHER fl fr (LEFT x) st = fl x st\r
+reduceEITHER fl fr (RIGHT x) st = fr x st\r
+\r
+
\ No newline at end of file
--- /dev/null
+definition module GenZip\r
+\r
+import StdMaybe, StdGeneric\r
+\r
+generic gZip a b c :: .a .b -> .c\r
+derive gZip Int, Bool, Char, Real, String, UNIT, EITHER, PAIR, CONS, FIELD, OBJECT\r
+derive gZip [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+generic gMaybeZip a b c :: .a .b -> Maybe .c\r
+derive gMaybeZip Int, Char, Bool, Real, String, UNIT, EITHER, PAIR, CONS, FIELD, OBJECT\r
+derive gMaybeZip [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
--- /dev/null
+implementation module GenZip\r
+\r
+import StdGeneric\r
+import StdEnv\r
+import StdMaybe\r
+\r
+derive bimap Maybe\r
+ \r
+generic gZip a b c :: .a .b -> .c\r
+gZip{|Int|} x y = if (x == y) x (abort "zip Int failed\n")\r
+gZip{|Bool|} x y = if (x == y) x (abort "zip Bool failed\n")\r
+gZip{|Char|} x y = if (x == y) x (abort "zip Char failed\n")\r
+gZip{|Real|} x y = if (x == y) x (abort "zip Real failed\n")\r
+gZip{|String|} x y = if (x == y) x (abort "zip String failed\n")\r
+gZip{|UNIT|} UNIT UNIT = UNIT\r
+gZip{|PAIR|} fx fy (PAIR x1 y1) (PAIR x2 y2) = PAIR (fx x1 x2) (fy y1 y2)\r
+gZip{|EITHER|} fl fr (LEFT x) (LEFT y) = LEFT (fl x y) \r
+gZip{|EITHER|} fl fr (RIGHT x) (RIGHT y) = RIGHT (fr x y) \r
+gZip{|EITHER|} fl fr _ _ = abort "gZip failed: EITHER does not match\n" \r
+gZip{|CONS|} f (CONS x) (CONS y) = CONS (f x y)\r
+gZip{|FIELD|} f (FIELD x) (FIELD y) = FIELD (f x y)\r
+gZip{|OBJECT|} f (OBJECT x) (OBJECT y) = OBJECT (f x y)\r
+derive gZip [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+ \r
+generic gMaybeZip a b c :: .a .b -> Maybe .c\r
+gMaybeZip{|Int|} x y = if (x == y) (Just x) Nothing\r
+gMaybeZip{|Bool|} x y = if (x == y) (Just x) Nothing\r
+gMaybeZip{|Char|} x y = if (x == y) (Just x) Nothing\r
+gMaybeZip{|Real|} x y = if (x == y) (Just x) Nothing\r
+gMaybeZip{|String|} x y = if (x == y) (Just x) Nothing\r
+gMaybeZip{|UNIT|} UNIT UNIT = Just UNIT\r
+gMaybeZip{|PAIR|} fx fy (PAIR x1 y1) (PAIR x2 y2) = zipMaybe PAIR (fx x1 x2) (fy y1 y2)\r
+gMaybeZip{|EITHER|} fl fr (LEFT x) (LEFT y) = mapMaybe LEFT (fl x y)\r
+gMaybeZip{|EITHER|} fl fr (RIGHT x) (RIGHT y) = mapMaybe RIGHT (fr x y)\r
+gMaybeZip{|EITHER|} fl fr _ _ = Nothing\r
+gMaybeZip{|CONS|} f (CONS x) (CONS y) = mapMaybe CONS (f x y)\r
+gMaybeZip{|FIELD|} f (FIELD x) (FIELD y) = mapMaybe FIELD (f x y)\r
+gMaybeZip{|OBJECT|} f (OBJECT x) (OBJECT y) = mapMaybe OBJECT (f x y)\r
+derive gMaybeZip [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+\r
+zipMaybe :: .(.a -> .(.b -> .c)) !(Maybe .a) (Maybe .b) -> (Maybe .c)\r
+zipMaybe f (Just x) (Just y) = Just (f x y)\r
+zipMaybe f _ _ = Nothing\r
+\r
--- /dev/null
+definition module _Array\r
+\r
+import StdArray\r
+\r
+createArrayUnsafe :: .Int -> u:(a v:b) | Array a b, [u <= v]\r
+\r
+\r
+/*\r
+class UnsafeArray a e | Array a e where\r
+ unsafeCreate :: !Int -> *(a .e)\r
+ unsafeUselect :: !u:(a .e) !Int -> *(.e, !u:(a .e))\r
+\r
+instance UnsafeArray {} e, {!} e\r
+\r
+mapArray :: (u:a -> v:b) w:(c u:a) -> x:(d v:b) | UnsafeArray c a & UnsafeArray d b, [w <= u,x <= v]\r
+mapArrayLSt :: (u:a -> .(.b -> (v:c,.b))) w:(d u:a) .b -> (x:(e v:c),.b) | UnsafeArray d a & UnsafeArray e c, [w <= u,x <= v]\r
+mapArrayRSt :: (u:a -> .(.b -> (v:c,.b))) w:(d u:a) .b -> (x:(e v:c),.b) | UnsafeArray d a & UnsafeArray e c, [w <= u,x <= v]\r
+*/\r
+\r
+class UnsafeArray a where\r
+ unsafeCreate :: !Int -> *(a .e)\r
+ unsafeUselect :: !u:(a .e) !Int -> *(.e, !u:(a .e))\r
+\r
+instance UnsafeArray {}, {!}\r
+\r
+mapArray :: (u:a -> v:b) w:(c u:a) -> x:(d v:b) | Array d b & UnsafeArray c & UnsafeArray d & Array c a, [w <= u,x <= v]\r
+mapArrayLSt :: (u:a -> .(.b -> (v:c,.b))) w:(d u:a) .b -> (x:(e v:c),.b) | Array e c & UnsafeArray d & UnsafeArray e & Array d a, [w <= u,x <= v]\r
+mapArrayRSt :: (u:a -> .(.b -> (v:c,.b))) w:(d u:a) .b -> (x:(e v:c),.b) | Array e c & UnsafeArray d & UnsafeArray e & Array d a, [w <= u,x <= v]\r
+reduceArray :: ((.a -> u:(b -> b)) -> .(b -> .(c -> .a))) (.a -> u:(b -> b)) b .(d c) -> b | Array d c\r
+reduceArrayLSt :: (u:a -> .(.b -> .b)) v:(c u:a) .b -> .b | UnsafeArray c & Array c a, [v <= u]\r
+reduceArrayRSt :: (u:a -> .(.b -> .b)) v:(c u:a) .b -> .b | UnsafeArray c & Array c a, [v <= u]\r
--- /dev/null
+implementation module _Array\r
+\r
+import _SystemArray, StdInt, StdClass\r
+\r
+\r
+createArrayUnsafe :: .Int -> u:(a v:b) | Array a b, [u <= v]\r
+createArrayUnsafe n = _createArray n\r
+\r
+\r
+instance UnsafeArray {} where \r
+ unsafeCreate size =\r
+ code\r
+ { \r
+ create_array_ _ 1 0\r
+ }\r
+ unsafeUselect arr index =\r
+ code\r
+ {\r
+ push_a 0\r
+ select _ 1 0\r
+ }\r
+\r
+instance UnsafeArray {!} where \r
+ unsafeCreate size =\r
+ code\r
+ { \r
+ create_array_ _ 1 0\r
+ }\r
+ unsafeUselect arr index =\r
+ code\r
+ {\r
+ push_a 0\r
+ select _ 1 0\r
+ }\r
+\r
+//mapArray :: (u:a -> v:b) w:(c u:a) -> x:(d v:b) | UnsafeArray c a & UnsafeArray d b, [w <= u,x <= v]\r
+mapArray :: (u:a -> v:b) w:(c u:a) -> x:(d v:b) | Array d b & UnsafeArray c & UnsafeArray d & Array c a, [w <= u,x <= v]\r
+mapArray f xs\r
+ #! (size_xs, xs) = usize xs\r
+ #! (xs, ys) = map f 0 size_xs xs (unsafeCreate size_xs)\r
+ = ys\r
+where\r
+ map f i n xs ys\r
+ | i == n \r
+ = (xs, ys)\r
+ | otherwise\r
+ #! (x, xs) = unsafeUselect xs i\r
+ #! ys = update ys i (f x) \r
+ = map f (inc i) n xs ys \r
+\r
+//mapArrayLSt :: (u:a -> .(.b -> (v:c,.b))) w:(d u:a) .b -> (x:(e v:c),.b) | UnsafeArray d a & UnsafeArray e c, [w <= u,x <= v]\r
+mapArrayLSt :: (u:a -> .(.b -> (v:c,.b))) w:(d u:a) .b -> (x:(e v:c),.b) | Array e c & UnsafeArray d & UnsafeArray e & Array d a, [w <= u,x <= v]\r
+mapArrayLSt f xs st\r
+ #! (size_xs, xs) = usize xs\r
+ #! (xs, ys, st) = map f 0 size_xs xs (unsafeCreate size_xs) st\r
+ = (ys, st)\r
+where\r
+ map f i n xs ys st\r
+ | i == n \r
+ = (xs, ys, st)\r
+ | otherwise\r
+ #! (x, xs) = unsafeUselect xs i\r
+ #! (y, st) = f x st\r
+ #! ys = update ys i y \r
+ = map f (inc i) n xs ys st\r
+\r
+//mapArrayRSt :: (u:a -> .(.b -> (v:c,.b))) w:(d u:a) .b -> (x:(e v:c),.b) | UnsafeArray d a & UnsafeArray e c, [w <= u,x <= v]\r
+mapArrayRSt :: (u:a -> .(.b -> (v:c,.b))) w:(d u:a) .b -> (x:(e v:c),.b) | Array e c & UnsafeArray d & UnsafeArray e & Array d a, [w <= u,x <= v]\r
+mapArrayRSt f xs st\r
+ #! (size_xs, xs) = usize xs\r
+ #! (xs, ys, st) = map f (size_xs - 1) xs (unsafeCreate size_xs) st\r
+ = (ys, st)\r
+where\r
+ map f i xs ys st\r
+ | i < 0 \r
+ = (xs, ys, st)\r
+ | otherwise\r
+ #! (x, xs) = unsafeUselect xs i\r
+ #! (y, st) = f x st\r
+ #! ys = update ys i y \r
+ = map f (dec i) xs ys st\r
+\r
+reduceArray :: ((.a -> u:(b -> b)) -> .(b -> .(c -> .a))) (.a -> u:(b -> b)) b .(d c) -> b | Array d c\r
+reduceArray f op e xs \r
+ = reduce f 0 (size xs) op e xs\r
+where\r
+ reduce f i n op e xs\r
+ | i == n \r
+ = e\r
+ | otherwise\r
+ = op (f op e xs.[i]) (reduce f (inc i) n op e xs) \r
+\r
+reduceArrayLSt :: (u:a -> .(.b -> .b)) v:(c u:a) .b -> .b | UnsafeArray c & Array c a, [v <= u]\r
+reduceArrayLSt f xs st\r
+ #! (size_xs, xs) = usize xs\r
+ #! (xs, st) = reduce f 0 size_xs xs st\r
+ = st\r
+where\r
+ reduce f i n xs st\r
+ | i == n \r
+ = (xs, st)\r
+ | otherwise\r
+ #! (x, xs) = unsafeUselect xs i\r
+ = reduce f (inc i) n xs (f x st)\r
+\r
+reduceArrayRSt :: (u:a -> .(.b -> .b)) v:(c u:a) .b -> .b | UnsafeArray c & Array c a, [v <= u]\r
+reduceArrayRSt f xs st\r
+ #! (size_xs, xs) = usize xs\r
+ #! (xs, st) = reduce f (dec size_xs) xs st\r
+ = st\r
+where\r
+ reduce f i xs st\r
+ | i < 0\r
+ = (xs, st)\r
+ | otherwise\r
+ #! (x, xs) = unsafeUselect xs i\r
+ = reduce f (dec i) xs (f x st)\r
--- /dev/null
+module gentest\r
+\r
+import StdEnv, GenLib\r
+\r
+:: Tree a b = Tip a | Bin b (Tree a b) (Tree a b)\r
+:: Rose a = Rose a .[Rose a]\r
+:: Fork a = Fork a a\r
+:: Sequ a = SequEmpty | SequZero .(Sequ .(Fork a)) | SequOne a .(Sequ .(Fork a))\r
+:: InfCons \r
+ = :+: infixl 2 InfCons InfCons\r
+ | :-: infixl 2 InfCons InfCons\r
+ | :*: infixl 3 InfCons InfCons\r
+ | :->: infixr 4 InfCons InfCons\r
+ | U\r
+ | I Int \r
+:: Rec a b c = { rec_fst :: a, rec_snd :: b, rec_thd :: c } \r
+:: Color = Red | Green | Blue\r
+\r
+derive bimap Tree, Rose, Fork, Sequ\r
+\r
+derive gEq Tree, Rose, Fork, Sequ, Color, InfCons, Rec, Maybe\r
+derive gLexOrd Tree, Rose, Fork, Sequ\r
+derive gMap Tree, Rose, Fork, Sequ\r
+derive gMapLSt Tree, Rose, Fork, Sequ\r
+derive gMapRSt Tree, Rose, Fork, Sequ\r
+derive gMapLM Tree, Rose, Fork, Sequ\r
+derive gMapRM Tree, Rose, Fork, Sequ\r
+derive gReduceLSt Tree, Rose, Fork, Sequ\r
+derive gReduceRSt Tree, Rose, Fork, Sequ\r
+derive gReduce Tree, Rose, Fork, Sequ\r
+derive gZip Tree, Rose, Fork, Sequ\r
+derive gMaybeZip Tree, Rose, Fork, Sequ\r
+derive gPrint Tree, Rose, Fork, Sequ, Color, InfCons, Rec\r
+derive gParse Tree, Rose, Fork, Sequ, Color, InfCons, Rec\r
+derive gCompress Tree, Rose, Fork, Sequ, Color\r
+derive gCompressedSize Tree, Rose, Fork, Sequ, Color\r
+derive gUncompress Tree, Rose, Fork, Sequ, Color\r
+derive gLookupFMap Tree, Rose, Fork, Sequ, Color\r
+derive gInsertFMap Tree, Rose, Fork, Sequ, Color\r
+\r
+tree = Bin 1 (Bin 2 (Tip 1.1) (Tip 2.2)) (Bin 3 (Tip 3.3) (Tip 4.4)) \r
+rose = Rose 1 [Rose 2 [], Rose 3 [Rose 5 [], Rose 6 []], Rose 4[]]\r
+sequ = SequZero (SequOne (Fork 1 2) (SequOne (Fork (Fork 3 4) (Fork 5 6)) SequEmpty))\r
+\r
+testEq :: [Bool]\r
+testEq = \r
+ [ [1,2,3] === [1,2,3]\r
+ , [1,2,3] =!= [1,2,3,4]\r
+ , [1,2,3] =!= [1,2,4] \r
+ , tree === tree\r
+ , rose === rose\r
+ , sequ === sequ\r
+ ]\r
+\r
+testLexOrd = \r
+ [ ([1,2,3] =?= [1,2,3]) === EQ \r
+ , ([1,2,3] =?= [1,2,3,4]) === LT\r
+ , ([1,2,4] =?= [1,2,3,4]) === GT\r
+ , (Rose 1 [Rose 2 [], Rose 3 []] =?= Rose 1 [Rose 2 [], Rose 3 []]) === EQ \r
+ , (Rose 1 [Rose 2 [], Rose 3 []] =?= Rose 1 [Rose 2 [], Rose 3 [], Rose 4 []]) === LT\r
+ , (Rose 1 [Rose 2 [], Rose 4 []] =?= Rose 1 [Rose 2 [], Rose 3 [], Rose 4 []]) === GT\r
+ ]\r
+ \r
+testMap =\r
+ [ gMap{|*->*|} inc [1,2,3] === [2,3,4]\r
+ , gMap{|*->*->*|} inc dec (Bin 1 (Tip 2.0) (Tip 3.0)) === Bin 0 (Tip 3.0) (Tip 4.0)\r
+ , gMap{|*->*|} inc (Rose 1 [Rose 2 [], Rose 3 []]) === Rose 2 [Rose 3 [], Rose 4 []] \r
+ , gMap{|*->*|} inc (SequZero (SequOne (Fork 1 2) (SequOne (Fork (Fork 3 4) (Fork 5 6)) SequEmpty)))\r
+ === SequZero (SequOne (Fork 2 3) (SequOne (Fork (Fork 4 5) (Fork 6 7)) SequEmpty))\r
+ ]\r
+\r
+testMapRSt =\r
+ [ gMapRSt{|*->*|} (\x st-> (dec x, [x:st])) [1,2,3] [] === ([0,1,2], [1,2,3]) \r
+ ] \r
+\r
+testMapLSt =\r
+ [ gMapLSt{|*->*|} (\x st-> (dec x, [x:st])) [1,2,3] [] === ([0,1,2], [3,2,1]) \r
+ ] \r
+\r
+testReduceRSt =\r
+ [ gReduceRSt{|*->*|} (\x st -> [x:st]) [1,2,3] [] === [1,2,3]\r
+ ]\r
+\r
+testReduceLSt =\r
+ [ gReduceLSt{|*->*|} (\x st -> [x:st]) [1,2,3] [] === [3,2,1]\r
+ ]\r
+\r
+testMapRM =\r
+ [ gMapRM{|*->*|} (Just o inc) [1,2,3] === (Just [2,3,4])\r
+ , (gMapRM{|*->*|} (\x -> {st_monad=(\xs -> (inc x, [x:xs]))}) [1,2,3]).st_monad [] === ([2,3,4], [1,2,3]) \r
+ ]\r
+\r
+testMapLM =\r
+ [ gMapLM{|*->*|} (Just o inc) [1,2,3] === (Just [2,3,4])\r
+ , (gMapLM{|*->*|} (\x -> {st_monad=(\xs -> (inc x, [x:xs]))}) [1,2,3]).st_monad [] === ([2,3,4], [3,2,1]) \r
+ ] \r
+\r
+testParsePrint =\r
+ [ test 1 \r
+ , test 123\r
+ , test -123\r
+\r
+ , test 1.09\r
+ , test 0.123\r
+ , test -123.456\r
+ , test 1.23E-12\r
+ , test 1.23E+12\r
+ , test 1.23E5\r
+\r
+ , test True\r
+ , test False\r
+\r
+ , test 'a'\r
+ , test '\n'\r
+ , test '"'\r
+ , test '\''\r
+ , test "Hello"\r
+ , test "Hello\n"\r
+ , test "Hello \"string\""\r
+\r
+ , test nil\r
+ , test [1]\r
+ , test [1,2,3]\r
+\r
+ , test (arr nil)\r
+ , test (arr [1])\r
+ , test (arr [1,2,3])\r
+\r
+ , test Red\r
+ , test Green\r
+ , test Blue\r
+\r
+ , test {rec_fst=1, rec_snd='a', rec_thd=1.2}\r
+\r
+ , test (Bin 'a' (Tip 1) (Bin 'b' (Tip 2) (Bin 'c' (Tip 3) (Tip 4))))\r
+ , test (Rose 1 [Rose 2 [], Rose 3 [], Rose 4 [Rose 5 []]])\r
+\r
+ , test (U :+: U)\r
+ , test (U :+: U :+: U)\r
+ , test (U :->: U :->: U)\r
+ , test (U :+: U :*: U)\r
+ , test (U :*: U :->: U)\r
+ , test (I 1 :+: I 2 :+: I 3)\r
+ , test (I 1 :*: I 2 :+: I 3)\r
+ , test (I 1 :+: I 2 :*: I 3)\r
+ , test (I 1 :+: I 2 :*: I 3 :+: I 4)\r
+ , test (I 1 :+: (I 2 :+: I 3) :+: I 4)\r
+\r
+ , test [I 1 :+: I 2 :+: I 3, I 4 :->: I 5 :->: I 6]\r
+ , test (arr [I 1 :+: I 2 :+: I 3, I 4 :->: I 5 :->: I 6])\r
+ , test \r
+ { rec_fst = I 1 :+: I 2 :+: I 3\r
+ , rec_snd = I 4 :->: I 5 :->: I 6\r
+ , rec_thd = I 7 :*: I 8 :+: I 9\r
+ }\r
+ ]\r
+where\r
+ test x = case parseString (printToString x) of\r
+ Nothing -> False\r
+ Just y -> x === y\r
+\r
+ nil :: [Int]\r
+ nil = []\r
+\r
+ arr :: [a] -> {a}\r
+ arr xs = {x\\x<-xs}\r
+\r
+\r
+testCompress =\r
+ [ test True\r
+ , test False\r
+ , test 12345\r
+ , test -2\r
+ , test 1.2345E20\r
+ , test [1 .. 100]\r
+ , test (flatten (repeatn 100 [Red, Green, Blue]))\r
+ //, test (flatten (repeatn 100000 [Red, Green, Blue]))\r
+ , test "hello"\r
+ , test 'a'\r
+ , test Green\r
+ , test Red\r
+ , test Blue \r
+ , test rose\r
+ , test (Bin Red (Tip Green) (Bin Blue (Tip Red) (Tip Green))) \r
+ , test sequ\r
+ ]\r
+where \r
+ test x = case uncompress (compress x) of\r
+ Nothing -> False\r
+ Just y -> x === y\r
+\r
+\r
+testFMap =\r
+ [ lookupFMap 1 fmap_int === Just 10\r
+ , lookupFMap 3 fmap_int === Just 30\r
+ , lookupFMap "two" fmap_str === Just 2\r
+ , lookupFMap "three" fmap_str === Just 3\r
+ , lookupFMap (Rose 1 [Rose 2 [], Rose 30 []]) fmap_rose === Just 3\r
+ , lookupFMap (Rose 1 [Rose 20 [], Rose 1 []]) fmap_rose === Just 100\r
+ ]\r
+where \r
+ fmap_int = emptyFMap \r
+ <<= (1, 10) \r
+ <<= (2, 20) \r
+ <<= (3,30) \r
+ <<= (4,40) \r
+ <<= (5, 50)\r
+ fmap_str = emptyFMap \r
+ <<= ("one", 1) \r
+ <<= ("two", 2) \r
+ <<= ("three", 3) \r
+ <<= ("four",4) \r
+ <<= ("five", 5)\r
+ fmap_rose = emptyFMap \r
+ <<= (Rose 1 [Rose 2 [], Rose 10 []], 1)\r
+ <<= (Rose 1 [Rose 2 [], Rose 20 []], 2)\r
+ <<= (Rose 1 [Rose 2 [], Rose 30 []], 3)\r
+ <<= (Rose 1 [Rose 2 [], Rose 40 []], 4)\r
+ <<= (Rose 1 [Rose 2 [], Rose 50 []], 5)\r
+ <<= (Rose 1 [Rose 20 [], Rose 1 []], 100)\r
+\r
+Start :: [[Bool]] \r
+Start\r
+ # result = foldr (&&) True (flatten tests)\r
+ | result\r
+ = [[result]]\r
+ = tests\r
+where\r
+ tests =\r
+ [ testEq\r
+ , testLexOrd\r
+ , testMap\r
+ , testMapRSt\r
+ , testMapLSt\r
+ , testMapRM\r
+ , testMapLM\r
+ , testReduceRSt\r
+ , testReduceLSt\r
+ , testParsePrint\r
+ , testCompress\r
+ , testFMap\r
+ ]\r
repositories / tt2015.git / commitdiff