3 -- These bindings are highly experimental and subject to change
4 -- without notice. You've been warned.
6 module Edu.Berkeley.Sbp.Haskell.SBP(
7 Tree(Tree),Location(Location),Region(Region),parseFile,prettyPrintTree,coalesceFlatHeadlessNodes)
10 #if defined(java_HOST_OS)
13 #define CONCAT(x,y) x/**/y
14 #define DEFINE_OBJECT(s,name) \
15 data CONCAT(name,_); \
16 type name = JObject CONCAT(name,_); \
17 foreign import jvm s CONCAT(_,name) :: JClass; \
18 instance JType_ CONCAT(name,_) where jClass_ _ = CONCAT(_,name);
21 import Class_HaskellHelper;
22 import Class_java_lang_Object;
23 import Class_java_lang_Class;
24 import Class_java_lang_String;
25 import Class_edu_berkeley_sbp_Tree;
26 import Header_edu_berkeley_sbp_Tree;
27 import JVM_HaskellHelper;
28 import Header_HaskellHelper;
36 --import Text.PrettyPrint.HughesPJ
37 import Text.PrettyPrint.Leijen
39 data Location = Location Int Int
40 data Region = Region Location Location
42 data Tree = Tree String [Tree] Region
45 show t@(Tree _ _ _) = show $ prettyPrintTree $ t
47 coalesceFlatHeadlessNodes t@(Tree s children r)
48 | s==[], flat t = Tree (concat $ map (\(Tree s _ _) -> s) children) [] r
49 | otherwise = Tree s (map coalesceFlatHeadlessNodes children) r
51 flat (Tree _ children _) = not (any id $ map notFlatComponent children)
52 notFlatComponent (Tree _ [] _) = False
53 notFlatComponent (Tree _ _ _) = True
56 prettyPrintTree (Tree "" [] _) = empty
57 prettyPrintTree (Tree s [] _) = text s
58 prettyPrintTree (Tree [] children _) = prettyPrintTreeList children
59 prettyPrintTree (Tree s children _) = (text (s++":")) <$$> (prettyPrintTreeList children)
60 prettyPrintTreeList [] = text "{}"
61 prettyPrintTreeList children
62 | allsingles children = text $ "\"" ++ (concatMap (\(Tree s _ _) -> s) children) ++ "\""
63 | otherwise = hang 2 $
67 ((fsep $ map (group . prettyPrintTree) children)
70 allsingles = all (\(Tree s c _) -> (length s)==1 && (length c)==0)
72 nullRegion = (Region (Location 0 0) (Location 0 0))
76 ------------------------------------------------------------------------------
77 #if defined(java_HOST_OS)
78 foreign import jvm type "edu.berkeley.sbp.Tree" JTree#
79 data JTree = JTree JTree#
80 foreign import jvm type "java.lang.Object" Object#
81 data Object = Object Object#
82 foreign import jvm safe "edu.berkeley.sbp.misc.RegressionTests.main" regressionTests :: IO ()
83 foreign import jvm safe "HaskellHelper.help" haskellHelper :: JString -> IO JTree
84 foreign import jvm safe "HaskellHelper.isNull" isNull :: Object -> IO Bool
85 foreign import jvm safe "getHead" getHead :: JTree -> IO Object
86 foreign import jvm safe "child" getChild :: JTree -> Int32 -> IO JTree
87 foreign import jvm safe "size" size :: JTree -> IO Int32
88 foreign import jvm safe "toString" jtoString :: Object -> IO JString
90 toString o = do isn <- isNull o
92 else do str <- jtoString o
93 return (unpackJString str)
96 haskify :: JTree -> IO Tree
100 numChildren <- size t
101 children <- if numChildren == 0
103 else do children <- mapM (\i -> getChild t i)
104 $ take (fromIntegral numChildren)
106 h <- mapM haskify children
108 return $ Tree str children nullRegion
111 String -> -- file to be parsed
114 parseFile f = do f' <- packJString f
115 tree <- haskellHelper f'
119 ------------------------------------------------------------------------------
121 -- Why do I need this?
122 instance SubJavaClassMarker
123 Header_edu_berkeley_sbp_Tree.Class_Jedu_berkeley_sbp_Tree
124 Header_HaskellHelper.Class_Jedu_berkeley_sbp_Tree
127 [String] -> -- class path
128 String -> -- grammar *.g file
129 String -> -- file to be parsed
132 parseFile classPath grammarFile inputFile =
134 ((do class_JHaskellHelper
135 s1 <- new_JString_ArrayJchar $ toJavaString grammarFile
136 s2 <- new_JString_ArrayJchar $ toJavaString inputFile
137 tree <- main_JHaskellHelper_JString_JString (s1, s2)
138 t <- haskifyTree tree
143 ((do class_JHaskellHelper
145 head <- getHead_JTree t ()
146 isNull <- getIsNothing head
147 str <- if isNull then (return "") else (toString_JObject ((castTLRef head) :: Jjava_lang_Object) () >>= getStringUTF >>= \x -> return (showUTF8 x))
148 numChildren <- size_JTree t()
149 children <- if numChildren == 0
151 else do children <- mapM (\i -> child_JTree_Jint t ((fromIntegral i)::Int32))
152 $ take (fromIntegral numChildren)
154 h <- mapM (\c -> haskifyTree (castTLRef c)) children
156 return $ Tree str children nullRegion