From 31bf84122b21efb444aa8d055472e166ffb90783 Mon Sep 17 00:00:00 2001 From: aarne Date: Tue, 20 May 2008 11:47:44 +0000 Subject: moved all old source code to src-2.9 ; src will be for GF 3 development --- src-2.9/GF/JavaScript/PrintJS.hs | 169 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 169 insertions(+) create mode 100644 src-2.9/GF/JavaScript/PrintJS.hs (limited to 'src-2.9/GF/JavaScript/PrintJS.hs') diff --git a/src-2.9/GF/JavaScript/PrintJS.hs b/src-2.9/GF/JavaScript/PrintJS.hs new file mode 100644 index 000000000..66e78346e --- /dev/null +++ b/src-2.9/GF/JavaScript/PrintJS.hs @@ -0,0 +1,169 @@ +{-# OPTIONS -fno-warn-incomplete-patterns #-} +module GF.JavaScript.PrintJS (printTree, Doc, Print(..)) where + +-- pretty-printer generated by the BNF converter + +import GF.JavaScript.AbsJS +import Char + +-- the top-level printing method +printTree :: Print a => a -> String +printTree = render . prt 0 + +type Doc = [ShowS] -> [ShowS] + +doc :: ShowS -> Doc +doc = (:) + +render :: Doc -> String +render d = rend 0 (map ($ "") $ d []) "" where + rend i ss = case ss of + t:ts | not (spaceAfter t) -> showString t . rend i ts + t:ts@(t':_) | not (spaceBefore t') -> showString t . rend i ts + t:ts -> space t . rend i ts + [] -> id + new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace + space t = showString t . (\s -> if null s then "" else (' ':s)) + +spaceAfter :: String -> Bool +spaceAfter = (`notElem` [".","(","[","{","\n"]) + +spaceBefore :: String -> Bool +spaceBefore = (`notElem` [",",".",":",";","(",")","[","]","{","}","\n"]) + +parenth :: Doc -> Doc +parenth ss = doc (showChar '(') . ss . doc (showChar ')') + +concatS :: [ShowS] -> ShowS +concatS = foldr (.) id + +concatD :: [Doc] -> Doc +concatD = foldr (.) id + +replicateS :: Int -> ShowS -> ShowS +replicateS n f = concatS (replicate n f) + +-- the printer class does the job +class Print a where + prt :: Int -> a -> Doc + prtList :: [a] -> Doc + prtList = concatD . map (prt 0) + +instance Print a => Print [a] where + prt _ = prtList + +instance Print Char where + prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'') + prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') + +mkEsc :: Char -> Char -> ShowS +mkEsc q s = case s of + _ | s == q -> showChar '\\' . showChar s + '\\'-> showString "\\\\" + '\n' -> showString "\\n" + '\t' -> showString "\\t" + _ -> showChar s + +prPrec :: Int -> Int -> Doc -> Doc +prPrec i j = if j (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + + + +instance Print Program where + prt i e = case e of + Program elements -> prPrec i 0 (concatD [prt 0 elements]) + + +instance Print Element where + prt i e = case e of + FunDef id ids stmts -> prPrec i 0 (concatD [doc (showString "function") , prt 0 id , doc (showString "(") , prt 0 ids , doc (showString ")") , doc (showString "{") , prt 0 stmts , doc (showString "}")]) + ElStmt stmt -> prPrec i 0 (concatD [prt 0 stmt]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , doc (showString "\n"), prt 0 xs]) -- HACKED! + +instance Print Stmt where + prt i e = case e of + SCompound stmts -> prPrec i 0 (concatD [doc (showString "{") , prt 0 stmts , doc (showString "}")]) + SReturnVoid -> prPrec i 0 (concatD [doc (showString "return") , doc (showString ";")]) + SReturn expr -> prPrec i 0 (concatD [doc (showString "return") , prt 0 expr , doc (showString ";")]) + SDeclOrExpr declorexpr -> prPrec i 0 (concatD [prt 0 declorexpr , doc (showString ";")]) + + prtList es = case es of + [] -> (concatD []) + x:xs -> (concatD [prt 0 x , prt 0 xs]) + +instance Print DeclOrExpr where + prt i e = case e of + Decl declvars -> prPrec i 0 (concatD [doc (showString "var") , prt 0 declvars]) + DExpr expr -> prPrec i 0 (concatD [prt 1 expr]) + + +instance Print DeclVar where + prt i e = case e of + DVar id -> prPrec i 0 (concatD [prt 0 id]) + DInit id expr -> prPrec i 0 (concatD [prt 0 id , doc (showString "=") , prt 0 expr]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print Expr where + prt i e = case e of + EAssign expr0 expr -> prPrec i 13 (concatD [prt 14 expr0 , doc (showString "=") , prt 13 expr]) + ENew id exprs -> prPrec i 14 (concatD [doc (showString "new") , prt 0 id , doc (showString "(") , prt 0 exprs , doc (showString ")")]) + EMember expr id -> prPrec i 15 (concatD [prt 15 expr , doc (showString ".") , prt 0 id]) + EIndex expr0 expr -> prPrec i 15 (concatD [prt 15 expr0 , doc (showString "[") , prt 0 expr , doc (showString "]")]) + ECall expr exprs -> prPrec i 15 (concatD [prt 15 expr , doc (showString "(") , prt 0 exprs , doc (showString ")")]) + EVar id -> prPrec i 16 (concatD [prt 0 id]) + EInt n -> prPrec i 16 (concatD [prt 0 n]) + EDbl d -> prPrec i 16 (concatD [prt 0 d]) + EStr str -> prPrec i 16 (concatD [prt 0 str]) + ETrue -> prPrec i 16 (concatD [doc (showString "true")]) + EFalse -> prPrec i 16 (concatD [doc (showString "false")]) + ENull -> prPrec i 16 (concatD [doc (showString "null")]) + EThis -> prPrec i 16 (concatD [doc (showString "this")]) + EFun ids stmts -> prPrec i 16 (concatD [doc (showString "function") , doc (showString "(") , prt 0 ids , doc (showString ")") , doc (showString "{") , prt 0 stmts , doc (showString "}")]) + EArray exprs -> prPrec i 16 (concatD [doc (showString "[") , prt 0 exprs , doc (showString "]")]) + EObj propertys -> prPrec i 16 (concatD [doc (showString "{") , prt 0 propertys , doc (showString "}")]) + ESeq exprs -> prPrec i 16 (concatD [doc (showString "(") , prt 0 exprs , doc (showString ")")]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print Property where + prt i e = case e of + Prop propertyname expr -> prPrec i 0 (concatD [prt 0 propertyname , doc (showString ":") , prt 0 expr]) + + prtList es = case es of + [] -> (concatD []) + [x] -> (concatD [prt 0 x]) + x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) + +instance Print PropertyName where + prt i e = case e of + IdentPropName id -> prPrec i 0 (concatD [prt 0 id]) + StringPropName str -> prPrec i 0 (concatD [prt 0 str]) + + + -- cgit v1.2.3