Deprecated: The each() function is deprecated. This message will be suppressed on further calls in /home/zhenxiangba/zhenxiangba.com/public_html/phproxy-improved-master/index.php on line 456
-- Haskell++ preprocessor. import System import Parselib -- strip comments, without changing layout -- BUG: This will be fooled by comment symbols in strings or one-line comments. comment n ('{':'-':s) = " "++comment (n+1) s comment (n+1) ('-':'}':s) = " "++comment n s comment n (c:s) | isSpace c = c:comment n s comment 0 (c:s) = c:comment 0 s comment (n+1) (c:s) = ' ':comment (n+1) s comment n [] = [] -- map between input/output and list of indented token lists preproc = filter (\(n,ts)->not (null ts)) . map (\l->(indentation l, lexs l)) . lines indentation = foldl (\n c->if c=='\t' then (n`div`8)*8+8 else n+1) 0 . takeWhile isSpace lexs l = case lex l of [] -> [] ("",_):_ -> [] (tok,l'):_ -> tok:lexs l' postproc = unlines . map (\(n,ts)->indent n++unwords ts) indent n | n>=8 = '\t':indent(n-8) | n>=1 = ' ':indent(n-1) | True = "" -- split into constructs according to offside rule offside [] = [] offside ((n,ts):zs) = let (xs,ys) = span (\(m,_)->m>n) zs in ((n,ts):xs):offside ys join = concat . map ((0,[]):) -- translate the extended constructs translate c = case snd (head c) of ("object":"class":_) -> objectClass (joinup c) ("object":"instance":_) -> objectInstance (joinup c) _ -> c where -- make decl structure explicit joinup ((n,ts):zs) = joinup' n ts zs joinup' n ts zs | "where" `elem` ts = (n,ts,offside zs) joinup' n ts ((_,us):zs) = joinup' n (ts++us) zs joinup' n ts [] = (n,ts,[]) objectClass (n,hdr,ops) = let (pref,c) = parse classHdr hdr in (n,["class",showpref [p++" obj"|p<-pref], c,"obj","where"]): [classDec n c (flat op) | op<-ops] ++ [classDef n (flat op) | op<-ops] where flat = concat . map snd classHdr = unitP (\pref c->(pref,c)) `doP` literal "object" `doP` literal "class" `apP` (prefix token) `apP` token `doP` (literal "where" `orelse` unitP "where") prefix p = unitP id `doP` literal "(" `apP` (p `sepBy` literal ",") `doP` literal ")" `doP` literal "=>" `orelse` unitP (\x->[x]) `apP` p `doP` literal "=>" `orelse` unitP [] showpref [] = "" showpref [c] = c++"=>" showpref (c:cs) = "("++c++concat[","++c'|c'<-cs]++") =>" classDec n c opdec = let (op,pref,ty) = parse opDec opdec in (n+2,(op++"Body::"++showpref((c++" self"):pref)++ "(obj->self)->obj->"):ty) opDec = unitP (\op pref ty->(op,pref,ty)) `apP` token `doP` literal "::" `apP` prefix (unitP (\x y->x++" "++y) `apP` token `apP` token) `apP` many token classDef n (op:_) = (n,[op++" obj = "++op++"Body id obj"]) -- we need obj as an explicit parameter here because of the -- monomorphism restriction. objectInstance (n,hdr,ops) = let (pref,cls,pat,typ,inh,from) = parse instanceHdr hdr in (n,("instance":showpref pref:cls:"(":typ++[")","where"])): concat [instanceDef (n+2) pat from op | op<-ops]++ [inheritDef (n+2) pat from op | op<-inh] instanceHdr = unitP (\pref cls pat typ (inh,from) -> (pref,cls,pat,typ,inh,from)) `doP` literal "object" `doP` literal "instance" `apP` prefix (unitP (\x y->x++" "++y) `apP` token `apP` token) `apP` token `doP` literal "(" `apP` untilSym "::" `apP` untilSym ")" `apP` inheriting `doP` (literal "where" `orelse` unitP "where") inheriting = unitP (\ns p->(ns,p)) `doP` literal "inheriting" `apP` (token `sepBy` literal ",") `doP` literal "from" `apP` token `orelse` unitP ([],"zaphod") -- untilSym requires that brackets match in the parsed sequence. untilSym s = unitP [] `doP` literal s `orelse` binP(++) (unitP (++[")"]) `apP` (binP (:) (literal "(") (untilSym ")"))) (untilSym s) `orelse` binP(:) (satisfy (/=s)) (untilSym s) p `sepBy` q = unitP (:) `apP` p `apP` many (unitP id `doP` q `apP` p) `orelse` unitP [] instanceDef n pat from ((_,op:xs):ys) = (n,(op++"Body self ("):pat++")":super pat from xs): [(m,super pat from zs)|(m,zs)<- ys] super pat from = map f where f s = if take 6 s == "super_" then "("++drop 6 s++"Body (self.(\\"++from++"->"++ unwords pat++")))" else s inheritDef n pat from op = (n,((op++"Body self ("):pat++ (") = "++op++"Body (self.(\\"++from++"->"):pat++ [")) "++from])) --main = interact (postproc . join . map translate . -- offside . preproc) translation = postproc . join . map translate . offside . preproc . comment 0 main = do args<-getArgs case args of [] -> interact translation [f] -> do s<-readFile (f++".h++") writeFile (f++".hs") (translation s) _ -> error "Usage: h++ \n"