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