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