Rev | Line | |
---|
[22] | 1 | module Size where |
---|
| 2 | |
---|
| 3 | import Lambda |
---|
| 4 | import Ops |
---|
| 5 | import Data.Supply as S |
---|
| 6 | |
---|
| 7 | data Unsized |
---|
| 8 | |
---|
| 9 | class (LOps l) => Size l where |
---|
| 10 | list :: l Int -> l (Int -> a) -> l [a] |
---|
| 11 | slam :: (l Int -> l (Int -> a) -> l b) -> l ([a] -> b) |
---|
| 12 | shift :: l (Int -> a) -> l Int -> l (Int -> a) -> l (Int -> a) |
---|
| 13 | unsized :: l Unsized |
---|
| 14 | bottom :: l a |
---|
| 15 | |
---|
| 16 | instance Size S where |
---|
| 17 | unsized = S $ \_ _ -> showChar 'U' |
---|
| 18 | bottom = S $ \_ _ -> showChar 'âŽ' |
---|
| 19 | list size sexp = S $ \s p -> |
---|
| 20 | let (s1, s2) = S.split2 s |
---|
| 21 | in showParen (p>0) $ |
---|
| 22 | showString "List " . |
---|
| 23 | unS size s1 9 . |
---|
| 24 | showChar ' ' . |
---|
| 25 | unS sexp s2 9 |
---|
| 26 | slam f = S $ \s p -> |
---|
| 27 | let (s1, s2, s3) = S.split3 s |
---|
| 28 | v1 = S.supplyValue s1 |
---|
| 29 | showV1 = S $ \_ _ -> showVar v1 |
---|
| 30 | v2 = S.supplyValue s2 |
---|
| 31 | showV2 = S $ \_ _ -> showVar v2 |
---|
| 32 | in showParen (p>0) $ |
---|
| 33 | showChar 'Î' . |
---|
| 34 | showVar v1 . |
---|
| 35 | showChar ',' . |
---|
| 36 | showVar v2 . |
---|
| 37 | showChar '.' . |
---|
| 38 | unS (f showV1 showV2) s3 0 |
---|
| 39 | shift e1 ss e2 = S $ \s p -> |
---|
| 40 | let (s1, s2, s3) = S.split3 s |
---|
| 41 | in showParen (p>0) |
---|
| 42 | $ showString "Shift " |
---|
| 43 | . unS e1 s1 2 |
---|
| 44 | . showChar ' ' |
---|
| 45 | . unS ss s2 2 |
---|
| 46 | . showChar ' ' |
---|
| 47 | . unS e2 s3 2 |
---|
Note: See
TracBrowser
for help on using the repository browser.