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 #define CONCAT(x,y) x/**/y
  13 #define DEFINE_OBJECT(s,name) \
  14 data CONCAT(name,_); \
  15 type name = JObject CONCAT(name,_); \
  16 foreign import jvm s CONCAT(_,name) :: JClass; \
  17 instance JType_ CONCAT(name,_) where jClass_ _ = CONCAT(_,name);
  18 #else
  19 import Header_Java;
  20 import Class_HaskellHelper;
  21 import Class_java_lang_Object;
  22 import Class_java_lang_Class;
  23 import Class_java_lang_String;
  24 import Class_edu_berkeley_sbp_Tree;
  25 import Header_edu_berkeley_sbp_Tree;
  26 import JVM_HaskellHelper;
  27 import Header_HaskellHelper;
  28 import TypedString;
  29 import JVMBridge;
  30 import JavaText;
  31 import JavaTypes;
  32 import Data.Int;
  33 import Invocation;
  34 #endif
  35 --import Text.PrettyPrint.HughesPJ
  36 import Text.PrettyPrint.Leijen
  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 fsep = fillSep
  55 prettyPrintTree (Tree "" []       _) = empty
  56 prettyPrintTree (Tree s  []       _) = text s
  57 prettyPrintTree (Tree [] children _) = prettyPrintTreeList children
  58 prettyPrintTree (Tree s  children _) = (text (s++":")) <$$> (prettyPrintTreeList children)
  59 prettyPrintTreeList []               = text "{}"
  60 prettyPrintTreeList children
  61     | allsingles children = text $ "\"" ++ (concatMap (\(Tree s _ _) -> s) children) ++ "\""
  62     | otherwise           = hang 2 $
  63                             (text "{")
  64                             <+>
  65                                (group
  66                                 ((fsep $ map (group . prettyPrintTree) children)
  67                                  <+>
  68                                  (text "}")))
  69 allsingles = all (\(Tree s c _) -> (length s)==1 && (length c)==0)
  70
  71 nullRegion = (Region (Location 0 0) (Location 0 0))
  72
  73
  74
  75 ------------------------------------------------------------------------------
  76 #if defined(java_HOST_OS)
  77 foreign import jvm type "edu.berkeley.sbp.Tree" JTree#
  78 data JTree = JTree JTree#
  79 foreign import jvm type "java.lang.Object" Object#
  80 data Object = Object Object#
  81 foreign import jvm safe "edu.berkeley.sbp.misc.RegressionTests.main" regressionTests :: IO ()
  82 foreign import jvm safe "HaskellHelper.help" haskellHelper :: JString -> IO JTree
  83 foreign import jvm safe "HaskellHelper.isNull" isNull :: Object -> IO Bool
  84 foreign import jvm safe "getHead" getHead :: JTree -> IO Object
  85 foreign import jvm safe "child" getChild :: JTree -> Int32 -> IO JTree
  86 foreign import jvm safe "size" size :: JTree -> IO Int32
  87 foreign import jvm safe "toString" jtoString :: Object -> IO JString
  88
  89 toString o  = do isn <- isNull o
  90                  if isn then return ""
  91                         else do str <- jtoString o
  92                                 return (unpackJString str)
  93
  94
  95 haskify :: JTree -> IO Tree
  96 haskify t =
  97   do head <- getHead t
  98      str  <- toString head
  99      numChildren <- size t
 100      children    <- if numChildren == 0
 101                         then do return []
 102                         else do children <- mapM (\i -> getChild t i)
 103                                               $ take (fromIntegral numChildren)
 104                                                 $ iterate (+1) 0
 105                                 h        <- mapM haskify children
 106                                 return h
 107      return $ Tree str children nullRegion
 108
 109 parseFile ::
 110  String   ->   -- file to be parsed
 111  IO Tree
 112
 113 parseFile f = do f' <- packJString f
 114                  tree <- haskellHelper f'
 115                  x <- haskify tree
 116                  return x
 117
 118 ------------------------------------------------------------------------------
 119 #else
 120   -- Why do I need this?
 121   instance SubJavaClassMarker
 122       Header_edu_berkeley_sbp_Tree.Class_Jedu_berkeley_sbp_Tree
 123       Header_HaskellHelper.Class_Jedu_berkeley_sbp_Tree
 124
 125   parseFile ::
 126    [String] ->   -- class path
 127    String   ->   -- grammar *.g file
 128    String   ->   -- file to be parsed
 129    IO Tree
 130
 131   parseFile classPath grammarFile inputFile =
 132      runJVM classPath
 133         ((do class_JHaskellHelper
 134              s1   <- new_JString_ArrayJchar $ toJavaString grammarFile
 135              s2   <- new_JString_ArrayJchar $ toJavaString inputFile
 136              tree <- main_JHaskellHelper_JString_JString (s1, s2)
 137              t <- haskifyTree tree
 138              return t
 139           ) :: JVM Tree)
 140
 141   haskifyTree t =
 142     ((do class_JHaskellHelper
 143          class_JTree
 144          head <- getHead_JTree t ()
 145          isNull <- getIsNothing head
 146          str  <- if isNull then (return "") else (toString_JObject ((castTLRef head) :: Jjava_lang_Object) () >>= getStringUTF >>= \x -> return (showUTF8 x))
 147          numChildren <- size_JTree t()
 148          children    <- if numChildren == 0
 149                         then do return []
 150                         else do children <- mapM (\i -> child_JTree_Jint t ((fromIntegral i)::Int32))
 151                                               $ take (fromIntegral numChildren)
 152                                                 $ iterate (+1) 0
 153                                 h        <- mapM (\c -> haskifyTree (castTLRef c)) children
 154                                 return h
 155          return $ Tree str children nullRegion
 156       ) :: JVM Tree)
 157
 158 #endif
 159 \end{code}