src/SBP.hs

   1 --
   2 -- These bindings are highly experimental and subject to change
   3 -- without notice.  You've been warned.
   4 --
   5
   6 module SBP
   7  where
   8   import Header_Java;
   9   import Class_edu_berkeley_sbp_misc_HaskellHelper;
  10   import Class_java_lang_Object;
  11   import Class_java_lang_Class;
  12   import Class_java_lang_String;
  13   import Class_edu_berkeley_sbp_Tree;
  14   import Header_edu_berkeley_sbp_Tree;
  15   import JVM_edu_berkeley_sbp_misc_HaskellHelper;
  16   import Header_edu_berkeley_sbp_misc_HaskellHelper;
  17   import TypedString;
  18   import JVMBridge;
  19   import JavaText;
  20   import JavaTypes;
  21   import Data.Int;
  22   import Invocation;
  23   import Text.PrettyPrint.HughesPJ
  24
  25   -- Why do I need this?
  26   instance SubJavaClassMarker
  27       Header_edu_berkeley_sbp_Tree.Class_Jedu_berkeley_sbp_Tree
  28       Header_edu_berkeley_sbp_misc_HaskellHelper.Class_Jedu_berkeley_sbp_Tree
  29
  30   data Location = Location Int Int
  31   data Region   = Region Location Location
  32
  33   data Tree     = Tree String [Tree] Region
  34   instance Show Tree
  35    where
  36     show t@(Tree _ _ _) = show $ prettyPrintTree $ t
  37
  38   coalesceFlatHeadlessNodes t@(Tree s children r)
  39     | s==[], flat t = Tree (concat $ map (\(Tree s _ _) -> s) children) [] r
  40     | otherwise     = Tree s (map coalesceFlatHeadlessNodes children) r
  41    where
  42     flat (Tree _ children _) = not (any id $ map notFlatComponent children)
  43     notFlatComponent (Tree _ [] _) = False
  44     notFlatComponent (Tree _ _  _) = True
  45
  46   prettyPrintTree (Tree "" []       _) = empty
  47   prettyPrintTree (Tree s  []       _) = text s
  48   prettyPrintTree t@(Tree s children _)
  49     | s==[]     = (text "{") <+> ((prettyPrintTreeList children) <+> (text "}"))
  50     | otherwise = ((text s) <> (text ":")) <+> prettyPrintTreeList children
  51      where
  52       prettyPrintTreeList children = (vcat $ map prettyPrintTree children)
  53
  54   nullRegion = (Region (Location 0 0) (Location 0 0))
  55
  56   parseFile ::
  57    [String] ->   -- class path
  58    String   ->   -- grammar *.g file
  59    String   ->   -- file to be parsed
  60    IO Tree
  61
  62   parseFile classPath grammarFile inputFile =
  63      runJVM classPath
  64         ((do class_JHaskellHelper
  65              s1   <- new_JString_ArrayJchar $ toJavaString grammarFile
  66              s2   <- new_JString_ArrayJchar $ toJavaString inputFile
  67              tree <- main_JHaskellHelper_JString_JString (s1, s2)
  68              t <- haskifyTree tree
  69              return t
  70           ) :: JVM Tree)
  71
  72   haskifyTree t =
  73     ((do class_JHaskellHelper
  74          class_JTree
  75          head <- getHead_JTree t ()
  76          isNull <- getIsNothing head
  77          str  <- if isNull then (return "") else (toString_JObject ((castTLRef head) :: Jjava_lang_Object) () >>= getStringUTF >>= \x -> return (showUTF8 x))
  78          numChildren <- size_JTree t()
  79          children    <- if numChildren == 0
  80                         then do return []
  81                         else do children <- mapM (\i -> child_JTree_Jint t ((fromIntegral i)::Int32))
  82                                               $ take (fromIntegral numChildren)
  83                                                 $ iterate (+1) 0
  84                                 h        <- mapM (\c -> haskifyTree (castTLRef c)) children
  85                                 return h
  86          return $ Tree str children nullRegion
  87       ) :: JVM Tree)
  88
  89