module Main (main, runProg) where import System.Environment import Data.Maybe (fromJust) import Data.Char (ord, chr, isUpper) import HazyParse import HazyAbstractElim usage = putStr$ "USAGE:\n\n"++ " hazy --> run file.hazy with stdin as input\n"++ " hazy -i --> run with input from commandline\n"++ " hazy -lazyk --> compile to Lazy K/S-K-I on stdout\n" ++ " hazy -debug --> show as list of compiled functions\n\n" main = do args <- getArgs case args of (file:"-i":input:[]) -> testFromFile file input ("-lazyk":file:[]) -> lazyk file ("-debug":file:[]) -> debug file [file] -> testFile file _ -> usage ------------------------------------------------------------------ -- run program or show debug output for your program format (k,v) = k ++ " = " ++ show v ++ "\n" debug file = do cnts <- readFile file case parseHazy cnts of Left err -> print err Right prog -> let skis = abstractElim prog keepers = killDeadCode "main" skis funcs = lines cnts in putStr $ unlines $ filter (/=[]) $ map (\ line -> if (takeWhile (/=' ') line) `elem` keepers then line else "") (lines cnts) -- in mapM_ (putStr . format) (keep keepers prog) keep keys kvs = filter (\(k,v) -> k `elem` keys) kvs testFile file = do prog <- readFile file input <- getContents --print $ map ord input test prog input testFromFile file input = do prog <- readFile file test prog input test cnts input = do case parseHazy cnts of Left err -> print err Right prog -> putStr (runProg (abstractElim prog) input) runProg :: Prog -> String -> String runProg p input = toString (e!(fromString input)) where e = interp p -------------------------------------------------------------- -- HHI: Haskell Haskell Interpreter: -- Matthew Naylor -- http://www.haskell.org/sitewiki/images/0/0a/TMR-Issue10.pdf interp :: Prog -> Exp interp p = fromJust (lookup "main" bs) where bs = prims ++ map (\(f, e) -> (f, link bs e)) p myLookup :: String -> [(String, a)] -> a myLookup kk [] = error $ "couldn't find function named: " ++ kk myLookup kk ((k,v):xs) | k == kk = v | otherwise = myLookup kk xs link bs (Ap f a) = link bs f ! link bs a --link bs (Fun f) = fromJust (lookup f bs) link bs (Fun f) = myLookup f bs link bs e = e -------------------------------------------------------------- -- encoding and decoding input and output streams toString :: Exp -> String toString list -- | isNull list = [] | ic <= 255 = c : toString xs | otherwise = [] where x = car list xs = cdr list ic = toChar x c = chr ic toChar :: Exp -> Int toChar e = fromInt (e ! succ_int ! Int 0) where succ_int = Lam$ \(Int x) -> Int (x+1) fromString :: String -> Exp fromString [] = cons (make_num 256 suc zero) (fromString []) -- make it loop with 256s forever -- OOPS: --nil fromString (x:xs) = cons (fromChar x) (fromString xs) fromChar :: Char -> Exp fromChar c = make_num (ord c) suc zero fromInt :: Exp -> Int fromInt (Int i) = i -- very unsafe! make_num :: Int -> (Exp -> Exp) -> Exp -> Exp make_num n f x | n <= 0 = x | otherwise = f $ make_num (n-1) f x nil, true, false, zero :: Exp true = Lam$ \x -> Lam$ \y -> x zero = Lam$ \f -> Lam$ \x -> x -- these are the same, zero and false false = Lam$ \x -> Lam$ \y -> y nil = Lam$ \f -> Lam$ \x -> Lam$ \y -> x cons :: Exp -> Exp -> Exp cons x y = Lam $ \f -> f!x!y car, cdr, suc :: Exp -> Exp car l = l ! true cdr l = l ! false suc n = Lam$ \f -> Lam$ \x -> f!(n!f!x) {- isNull :: Exp -> Bool isNull l = b == 1 where tf = l ! (Lam$ \x -> Lam$ \y -> false) b = fromInt2 (tf ! Int 1 ! Int 0) -} -------------------------------------------------------------- -- compile to Lazy K [] `without` k = error$ show k ++ " not found" (kv@(k,v):rest) `without` key | k == key = rest | otherwise = kv : (rest `without` key) {- -- was supposed to remove double parens but removed too many and changed the meaning of the program! oops scanner [] = [] scanner ('(':'(':rest) = scanner $ dorem 0 ('(':rest) scanner (x:xs) = x : scanner xs dorem n (')':rest) | n == 0 = rest | otherwise = ')' : dorem (n-1) rest dorem n ('(':rest) = '(' : dorem (n+1) rest dorem n (x:xs) = x : dorem n xs -} cleanup x = maxWid '\n' 60 x maxWid ch n x = splitter ch n ("", x) splitter ch n (a,[]) = a splitter ch n ([],b) = splitter ch n (splitAt n b) splitter ch n (a,b) = a ++ ch : splitter ch n (splitAt n b) -- prevent extra parens! since ((xy)z) is (xyz) substAll prog (Ap (Ap z w) y) = "("++ substAll prog z ++""++ substAll prog w ++""++ substAll prog y ++")" substAll prog (Ap x y) = "("++ substAll prog x ++""++ substAll prog y ++")" substAll prog (Fun name) | isUpper $ name!!0 = name | otherwise = case lookup name prog of Nothing -> error$ "function "++name++" not found" Just rhs -> substAll (prog `without` name) rhs reduce func prog = case lookup func prog of Just body -> cleanup $ substAll (prog `without` func) body Nothing -> error $ "Function "++ func ++" not found." lazyk file = do cnts <- readFile file case parseHazy cnts of Left err -> print err Right prog -> putStr $ filter (/=' ') (reduce "main" (compileToSKI prog)) killDeadCode name funcs = killer name funcs [] killer name funcs acc = case lookup name funcs of Just body -> let lessFuncs = funcs `without` name in name : finder lessFuncs body Nothing -> error$ "Function "++ name ++" not found." finder prog (Ap x y) = finder prog x ++ finder prog y finder prog (Fun name) | isUpper $ name!!0 = [] | otherwise = case lookup name prog of Nothing -> error$ "Function "++name++" not found." Just rhs -> name : finder (prog `without` name) rhs finder prog _ = []