src/SBP.lhs

   1 \begin{code}
   2 --
   3 -- These bindings are highly experimental and subject to change
   4 -- without notice.  You've been warned.
   5 --
   6 module SBP(Tree(Tree),Location(Location),Region(Region),parseFile,prettyPrintTree)
   7  where
   8
   9 #if defined(java_HOST_OS)
  10
  11 #define CONCAT(x,y) x/**/y
  12 #define DEFINE_OBJECT(s,name) \
  13 data CONCAT(name,_); \
  14 type name = Object CONCAT(name,_); \
  15 foreign import jvm s CONCAT(_,name) :: JClass; \
  16 instance JType_ CONCAT(name,_) where jClass_ _ = CONCAT(_,name);
  17
  18 import Foreign
  19 import Foreign.Java
  20 import Text.PrettyPrint.HughesPJ
  21
  22 data Location = Location Int Int
  23 data Region   = Region Location Location
  24
  25 data Tree     = Tree String [Tree] Region
  26 instance Show Tree
  27  where
  28   show t@(Tree _ _ _) = show $ prettyPrintTree $ t
  29
  30 coalesceFlatHeadlessNodes t@(Tree s children r)
  31   | s==[], flat t = Tree (concat $ map (\(Tree s _ _) -> s) children) [] r
  32   | otherwise     = Tree s (map coalesceFlatHeadlessNodes children) r
  33  where
  34   flat (Tree _ children _) = not (any id $ map notFlatComponent children)
  35   notFlatComponent (Tree _ [] _) = False
  36   notFlatComponent (Tree _ _  _) = True
  37
  38 prettyPrintTree (Tree "" []       _) = empty
  39 prettyPrintTree (Tree s  []       _) = text s
  40 prettyPrintTree t@(Tree s children _)
  41   | s==[]     = (text "{") <+> ((prettyPrintTreeList children) <+> (text "}"))
  42   | otherwise = ((text s) <> (text ":")) <+> prettyPrintTreeList children
  43    where
  44     prettyPrintTreeList children = (vcat $ map prettyPrintTree children)
  45
  46 nullRegion = (Region (Location 0 0) (Location 0 0))
  47
  48 foreign import jvm type "edu.berkeley.sbp.Tree" JTree#
  49 data JTree = JTree JTree#
  50
  51 foreign import jvm safe "edu.berkeley.sbp.misc.RegressionTests.main" regressionTests :: IO ()
  52 foreign import jvm safe "edu.berkeley.sbp.misc.HaskellHelper.help" haskellHelper :: JString -> JString -> IO JTree
  53 foreign import jvm safe "edu.berkeley.sbp.misc.HaskellHelper.isNull" isNull :: (Object a) -> IO Bool
  54 foreign import jvm safe "getHead" getHead :: JTree -> IO (Object a)
  55 foreign import jvm safe "child" getChild :: JTree -> Int32 -> IO JTree
  56 foreign import jvm safe "size" size :: JTree -> IO Int32
  57 foreign import jvm safe "toString" jtoString :: (Object a) -> IO JString
  58
  59 toString o  = do isn <- isNull o
  60                  if isn then return ""
  61                         else do str <- jtoString o
  62                                 return (unpackJString str)
  63
  64
  65 haskify :: JTree -> IO Tree
  66 haskify t =
  67   do head <- getHead t
  68      str  <- toString head
  69      numChildren <- size t
  70      children    <- if numChildren == 0
  71                         then do return []
  72                         else do children <- mapM (\i -> getChild t i)
  73                                               $ take (fromIntegral numChildren)
  74                                                 $ iterate (+1) 0
  75                                 h        <- mapM haskify children
  76                                 return h
  77      return $ Tree str children nullRegion
  78
  79 parseFile ::
  80  String   ->   -- grammar *.g file
  81  String   ->   -- file to be parsed
  82  IO Tree
  83
  84 parseFile g f = do g' <- packJString g
  85                    f' <- packJString f
  86                    tree <- haskellHelper g' f'
  87                    x <- haskify tree
  88                    return x
  89
  90 #else
  91   import Header_Java;
  92   import Class_edu_berkeley_sbp_misc_HaskellHelper;
  93   import Class_java_lang_Object;
  94   import Class_java_lang_Class;
  95   import Class_java_lang_String;
  96   import Class_edu_berkeley_sbp_Tree;
  97   import Header_edu_berkeley_sbp_Tree;
  98   import JVM_edu_berkeley_sbp_misc_HaskellHelper;
  99   import Header_edu_berkeley_sbp_misc_HaskellHelper;
 100   import TypedString;
 101   import JVMBridge;
 102   import JavaText;
 103   import JavaTypes;
 104   import Data.Int;
 105   import Invocation;
 106   import Text.PrettyPrint.HughesPJ
 107
 108   -- Why do I need this?
 109   instance SubJavaClassMarker
 110       Header_edu_berkeley_sbp_Tree.Class_Jedu_berkeley_sbp_Tree
 111       Header_edu_berkeley_sbp_misc_HaskellHelper.Class_Jedu_berkeley_sbp_Tree
 112
 113   data Location = Location Int Int
 114   data Region   = Region Location Location
 115
 116   data Tree     = Tree String [Tree] Region
 117   instance Show Tree
 118    where
 119     show t@(Tree _ _ _) = show $ prettyPrintTree $ t
 120
 121   coalesceFlatHeadlessNodes t@(Tree s children r)
 122     | s==[], flat t = Tree (concat $ map (\(Tree s _ _) -> s) children) [] r
 123     | otherwise     = Tree s (map coalesceFlatHeadlessNodes children) r
 124    where
 125     flat (Tree _ children _) = not (any id $ map notFlatComponent children)
 126     notFlatComponent (Tree _ [] _) = False
 127     notFlatComponent (Tree _ _  _) = True
 128
 129   prettyPrintTree (Tree "" []       _) = empty
 130   prettyPrintTree (Tree s  []       _) = text s
 131   prettyPrintTree t@(Tree s children _)
 132     | s==[]     = (text "{") <+> ((prettyPrintTreeList children) <+> (text "}"))
 133     | otherwise = ((text s) <> (text ":")) <+> prettyPrintTreeList children
 134      where
 135       prettyPrintTreeList children = (vcat $ map prettyPrintTree children)
 136
 137   nullRegion = (Region (Location 0 0) (Location 0 0))
 138
 139   parseFile ::
 140    [String] ->   -- class path
 141    String   ->   -- grammar *.g file
 142    String   ->   -- file to be parsed
 143    IO Tree
 144
 145   parseFile classPath grammarFile inputFile =
 146      runJVM classPath
 147         ((do class_JHaskellHelper
 148              s1   <- new_JString_ArrayJchar $ toJavaString grammarFile
 149              s2   <- new_JString_ArrayJchar $ toJavaString inputFile
 150              tree <- main_JHaskellHelper_JString_JString (s1, s2)
 151              t <- haskifyTree tree
 152              return t
 153           ) :: JVM Tree)
 154
 155   haskifyTree t =
 156     ((do class_JHaskellHelper
 157          class_JTree
 158          head <- getHead_JTree t ()
 159          isNull <- getIsNothing head
 160          str  <- if isNull then (return "") else (toString_JObject ((castTLRef head) :: Jjava_lang_Object) () >>= getStringUTF >>= \x -> return (showUTF8 x))
 161          numChildren <- size_JTree t()
 162          children    <- if numChildren == 0
 163                         then do return []
 164                         else do children <- mapM (\i -> child_JTree_Jint t ((fromIntegral i)::Int32))
 165                                               $ take (fromIntegral numChildren)
 166                                                 $ iterate (+1) 0
 167                                 h        <- mapM (\c -> haskifyTree (castTLRef c)) children
 168                                 return h
 169          return $ Tree str children nullRegion
 170       ) :: JVM Tree)
 171
 172 #endif
 173 \end{code}