src/edu/berkeley/sbp/haskell/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 -- Warning: this is no longer maintained.  It stopped working in mid-2009.
   7 --
   8 module Edu_Berkeley_Sbp_Haskell_SBP(
   9   Tree(Tree),Location(Location),Region(Region),parseFile,prettyPrintTree,coalesceFlatHeadlessNodes)
  10 where
  11
  12 #if defined(java_HOST_OS)
  13 import Foreign
  14 import Foreign.Java
  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);
  21 #else
  22 {-
  23 import Header_Java;
  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;
  32 import TypedString;
  33 import JVMBridge;
  34 import JavaText;
  35 import JavaTypes;
  36 import Data.Int;
  37 import Invocation;
  38 -}
  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;
  44 import Data.Witness;
  45 import Control.Concurrent;
  46 import System.IO;
  47 #endif
  48 import Text.PrettyPrint.Leijen
  49
  50 data Location = Location Int Int
  51 data Region   = Region Location Location
  52
  53 data Tree     = Tree String [Tree] Region
  54 instance Show Tree
  55  where
  56   show t@(Tree _ _ _) = show $ prettyPrintTree $ t
  57
  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
  61  where
  62   flat (Tree _ children _) = not (any id $ map notFlatComponent children)
  63   notFlatComponent (Tree _ [] _) = False
  64   notFlatComponent (Tree _ _  _) = True
  65
  66 fsep = fillSep
  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 $
  75                             (text "{")
  76                             <+>
  77                                (group
  78                                 ((fsep $ map (group . prettyPrintTree) children)
  79                                  <+>
  80                                  (text "}")))
  81 allsingles = all (\(Tree s c _) -> (length s)==1 && (length c)==0)
  82
  83 nullRegion = (Region (Location 0 0) (Location 0 0))
  84
  85
  86
  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
 100
 101 toString o  = do isn <- isNull o
 102                  if isn then return ""
 103                         else do str <- jtoString o
 104                                 return (unpackJString str)
 105
 106
 107 haskify :: JTree -> IO Tree
 108 haskify t =
 109   do head <- getHead t
 110      str  <- toString head
 111      numChildren <- size t
 112      children    <- if numChildren == 0
 113                         then do return []
 114                         else do children <- mapM (\i -> getChild t i)
 115                                               $ take (fromIntegral numChildren)
 116                                                 $ iterate (+1) 0
 117                                 h        <- mapM haskify children
 118                                 return h
 119      return $ Tree str children nullRegion
 120
 121 parseFile ::
 122  String   ->   -- file to be parsed
 123  IO Tree
 124
 125 parseFile f = do f' <- packJString f
 126                  tree <- haskellHelper f'
 127                  x <- haskify tree
 128                  return x
 129
 130 ------------------------------------------------------------------------------
 131 #else
 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
 136
 137 parseFile ::
 138    [String] ->   -- class path
 139    String   ->   -- grammar *.g file
 140    String   ->   -- file to be parsed
 141    IO Tree
 142
 143 parseFile classPath grammarFile inputFile =
 144      runJVM classPath
 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
 150              return t
 151           ) :: JVM Tree)
 152
 153 haskifyTree t =
 154     ((do class_JHaskellHelper
 155          class_JTree
 156          head <- getHead_JTree t ()
 157          isNull <- getIsNothing head
 158          str  <- if isNull
 159                  then (return "")
 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
 164                         then do return []
 165                         else do children <- mapM (\i -> child_JTree_Jint t ((fromIntegral i)::Int32))
 166                                               $ take (fromIntegral numChildren)
 167                                                 $ iterate (+1) 0
 168                                 h        <- mapM (\c -> haskifyTree (castTLRef c)) children
 169                                 return h
 170          return $ Tree str children nullRegion
 171       ) :: JVM Tree)
 172
 173 #endif
 174 \end{code}