3 -- These bindings are highly experimental and subject to change
4 -- without notice. You've been warned.
6 -- Warning: this is no longer maintained. It stopped working in mid-2009.
8 module Edu_Berkeley_Sbp_Haskell_SBP(
9 Tree(Tree),Location(Location),Region(Region),parseFile,prettyPrintTree,coalesceFlatHeadlessNodes)
12 #if defined(java_HOST_OS)
15 #define CONCAT(x,y) x/**/y
16 #define DEFINE_OBJECT(s,name) \
17 data CONCAT(name,_); \
18 type name = JObject CONCAT(name,_); \
19 foreign import jvm s CONCAT(_,name) :: JClass; \
20 instance JType_ CONCAT(name,_) where jClass_ _ = CONCAT(_,name);
24 import Class_HaskellHelper;
25 import Class_java_lang_Object;
26 import Class_java_lang_Class;
27 import Class_java_lang_String;
28 import Class_edu_berkeley_sbp_Tree;
29 import Header_edu_berkeley_sbp_Tree;
30 import JVM_HaskellHelper;
31 import Header_HaskellHelper;
39 import Foreign.JavaVM.Lib.Class_java_lang_System;
40 import Foreign.JavaVM.Lib.Class_java_lang_String;
41 import TestCallback_JVM;
42 import Foreign.JavaVM;
43 import Platform.JavaVM;
45 import Control.Concurrent;
48 import Text.PrettyPrint.Leijen
50 data Location = Location Int Int
51 data Region = Region Location Location
53 data Tree = Tree String [Tree] Region
56 show t@(Tree _ _ _) = show $ prettyPrintTree $ t
58 coalesceFlatHeadlessNodes t@(Tree s children r)
59 | s==[], flat t = Tree (concat $ map (\(Tree s _ _) -> s) children) [] r
60 | otherwise = Tree s (map coalesceFlatHeadlessNodes children) r
62 flat (Tree _ children _) = not (any id $ map notFlatComponent children)
63 notFlatComponent (Tree _ [] _) = False
64 notFlatComponent (Tree _ _ _) = True
67 prettyPrintTree (Tree "" [] _) = empty
68 prettyPrintTree (Tree s [] _) = text s
69 prettyPrintTree (Tree [] children _) = prettyPrintTreeList children
70 prettyPrintTree (Tree s children _) = (text (s++":")) <$$> (prettyPrintTreeList children)
71 prettyPrintTreeList [] = text "{}"
72 prettyPrintTreeList children
73 | allsingles children = text $ "\"" ++ (concatMap (\(Tree s _ _) -> s) children) ++ "\""
74 | otherwise = hang 2 $
78 ((fsep $ map (group . prettyPrintTree) children)
81 allsingles = all (\(Tree s c _) -> (length s)==1 && (length c)==0)
83 nullRegion = (Region (Location 0 0) (Location 0 0))
87 ------------------------------------------------------------------------------
88 #if defined(java_HOST_OS)
89 foreign import jvm type "edu.berkeley.sbp.Tree" JTree#
90 data JTree = JTree JTree#
91 foreign import jvm type "java.lang.Object" Object#
92 data Object = Object Object#
93 foreign import jvm safe "edu.berkeley.sbp.misc.RegressionTests.main" regressionTests :: IO ()
94 foreign import jvm safe "HaskellHelper.help" haskellHelper :: JString -> IO JTree
95 foreign import jvm safe "HaskellHelper.isNull" isNull :: Object -> IO Bool
96 foreign import jvm safe "getHead" getHead :: JTree -> IO Object
97 foreign import jvm safe "child" getChild :: JTree -> Int32 -> IO JTree
98 foreign import jvm safe "size" size :: JTree -> IO Int32
99 foreign import jvm safe "toString" jtoString :: Object -> IO JString
101 toString o = do isn <- isNull o
102 if isn then return ""
103 else do str <- jtoString o
104 return (unpackJString str)
107 haskify :: JTree -> IO Tree
111 numChildren <- size t
112 children <- if numChildren == 0
114 else do children <- mapM (\i -> getChild t i)
115 $ take (fromIntegral numChildren)
117 h <- mapM haskify children
119 return $ Tree str children nullRegion
122 String -> -- file to be parsed
125 parseFile f = do f' <- packJString f
126 tree <- haskellHelper f'
130 ------------------------------------------------------------------------------
132 -- Why do I need this?
133 instance SubJavaClassMarker
134 Header_edu_berkeley_sbp_Tree.Class_Jedu_berkeley_sbp_Tree
135 Header_HaskellHelper.Class_Jedu_berkeley_sbp_Tree
138 [String] -> -- class path
139 String -> -- grammar *.g file
140 String -> -- file to be parsed
143 parseFile classPath grammarFile inputFile =
145 ((do class_JHaskellHelper
146 s1 <- new_JString_ArrayJchar $ toJavaString grammarFile
147 s2 <- new_JString_ArrayJchar $ toJavaString inputFile
148 tree <- main_JHaskellHelper_JString_JString (s1, s2)
149 t <- haskifyTree tree
154 ((do class_JHaskellHelper
156 head <- getHead_JTree t ()
157 isNull <- getIsNothing head
160 else (toString_JObject ((castTLRef head) :: Jjava_lang_Object) ()
161 >>= getStringUTF >>= \x -> return (showUTF8 x))
162 numChildren <- size_JTree t()
163 children <- if numChildren == 0
165 else do children <- mapM (\i -> child_JTree_Jint t ((fromIntegral i)::Int32))
166 $ take (fromIntegral numChildren)
168 h <- mapM (\c -> haskifyTree (castTLRef c)) children
170 return $ Tree str children nullRegion