checkpoint

[fleet.git] / src / edu / berkeley / fleet / f0 / Types.lhs

diff --git a/src/edu/berkeley/fleet/f0/Types.lhs b/src/edu/berkeley/fleet/f0/Types.lhs
index eb955e8..f82c411 100644 (file)
--- a/src/edu/berkeley/fleet/f0/Types.lhs
+++ b/src/edu/berkeley/fleet/f0/Types.lhs
@@ -13,13 +13,13 @@ instance Show Def where
    commify x = join "," x
 instance FromTree Def where
   fromTree (Tree "Def" [name,inp,outp,es] _) =
-     Def (fromTree name) (fromTree inp) (fromTree outp) (Par (fromTree es))
+     Def (fromTree name) (fromTree inp) (fromTree outp) (fromTree es)
   fromTree (Tree "Def" q _) = error $ show q
 
 -- Port ------------------------------------------------------------------------------
 data Port = ShipPort String String
           | IdPort   String
- deriving Eq
+ deriving (Eq, Ord)
 
 instance Show Port where
  show (ShipPort a b) = a++"."++b
@@ -32,35 +32,54 @@ instance FromTree Port where
 
 
 -- Expr ------------------------------------------------------------------------------
-data Expr = Decl     String  String
-          | Seq      [Expr] 
-          | Par      [Expr]
-          | Move     Int Port    [Port]
-          | Literal  Int Int     [Port]
-  deriving Eq
-
+data Decl  = Decl String String
+  deriving (Show,Eq)
+data Expr  = Seq     [Expr] 
+           | Par     [Expr]
+           | Exprs   [Decl] Expr
+           | Move     Int Port    Port
+           | Literal  Int Int     Port
+           | Nop
+  deriving (Show,Eq)
+{-
 instance Show Expr where
  show (Decl shipName shipType) = shipName ++ " :: " ++ shipType
  show (Seq  exprs)             = join " ;; " $ map (\x -> "{ "++x++" }") $ map show exprs
  show (Par  [expr])            = show expr
  show (Par  exprs)             = "{ " ++ (join "\n   " $ map show exprs) ++ " }"
- show (Move 0 source dests)      = (show source) ++ " -[*]-> " ++ (join "," $ map show dests)
- show (Move 1 source dests)      = (show source) ++ " --> " ++ (join "," $ map show dests)
- show (Move count source dests)      = (show source) ++ " -["++(show count)++"]-> " ++ (join "," $ map show dests)
+ show (Move 0 source dest)      = (show source) ++ " -[*]-> " ++ (show dest)
+ show (Move 1 source dest)      = (show source) ++ " --> " ++ (show dest)
+ show (Move count source dest)      = (show source) ++ " -["++(show count)++"]-> " ++ (show dest)
  show (Literal 0 i dest)   = (show i) ++ " -[*]-> " ++ (show dest)
  show (Literal 1 i dest)   = (show i) ++ " --> " ++ (show dest)
  show (Literal count i dest)   = (show i) ++ " -["++(show count)++"]-> " ++ (show dest)
+-}
+
+instance FromTree Decl where
+ fromTree (Tree "::" [shipName,shipType] _) = Decl    (fromTree shipName) (fromTree shipType)
 
 instance FromTree Expr where
-  fromTree (Tree "::"     [shipName,shipType] _)                = Decl    (fromTree shipName) (fromTree shipType)
-  fromTree (Tree "-->"    [(Tree i [] _),dest] _)               = Literal 1        (read i)          (fromTree dest)
-  fromTree (Tree "-->"    [source,dest] _)                      = Move    1        (fromTree source) (fromTree dest)
-  fromTree (Tree "-["     [(Tree i [] _),(Tree c [] _),dest] _) = Literal (read c) (read i)            (fromTree dest)
-  fromTree (Tree "-["     [source,(Tree c [] _),dest] _)        = Move    (read c) (fromTree source)   (fromTree dest)
-  fromTree (Tree "-[*]->" [(Tree i [] _),dest] _)               = Literal 0        (read i)            (fromTree dest)
-  fromTree (Tree "-[*]->" [source,dest] _)                      = Move    0        (fromTree source)   (fromTree dest)
-  fromTree t@(Tree "{"    [(Tree _ e _)] _)                     = Par     (map fromTree e)
-  fromTree t@(Tree ";;"   [a,b] _)                              = Seq    [(fromTree a), (fromTree b)]
-  fromTree other = error  (show other)
+  fromTree (Tree "Exprs" [decls, sequents] _) = Exprs (fromTree decls) (seq $ map par $ fromTree sequents)
+   where seq []  = Nop
+         seq [x] = x
+         seq x   = Seq x
+         par []  = Nop
+         par [x] = x
+         par x   = Par x
+  fromTree (Tree "-->" es _) =
+   case es of
+    [(Tree i [] _),dest]              -> rep (fromTree dest) $ \d -> Literal 1 (read i) d
+    [(Tree "{" [Tree _ is _] _),dest] -> Par $ concatMap (\d -> map (\(Tree i _ _) -> Literal 1 (read i) d) is) (fromTree dest)
+    [source,dest]                     -> rep (fromTree dest) $ \d -> Move 1 (fromTree source) d
+--  fromTree (Tree "-["     [(Tree i [] _),(Tree c [] _),dest] _) = Literal (read c) (read i)            (fromTree dest)
+--  fromTree (Tree "-["     [source,(Tree c [] _),dest] _)        = Move    (read c) (fromTree source)   (fromTree dest)
+--  fromTree (Tree "-[*]->" [(Tree i [] _),dest] _)               = Literal 0        (read i)            (fromTree dest)
+--  fromTree (Tree "-[*]->" [source,dest] _)                      = Move    0        (fromTree source)   (fromTree dest)
+  fromTree other = error  $ (show other)
+
+rep :: [Port] -> (Port -> Expr) -> Expr
+rep []   _ = error "nop"
+rep [x]  f = f x
+rep list f = Par $ map f list
 
 \end{code}
\ No newline at end of file