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