final pass to update instruction encoding; should now match the spec

[fleet.git] / contrib / f0 / Types.lhs

diff --git a/contrib/f0/Types.lhs b/contrib/f0/Types.lhs
new file mode 100644 (file)
index 0000000..be42cb2
--- /dev/null
+++ b/contrib/f0/Types.lhs
@@ -0,0 +1,95 @@
+\begin{code}
+module Types where
+import SBP
+import Util
+import Fleet
+
+-- Def ------------------------------------------------------------------------------
+data Def = Def String [String] [String] Expr
+  deriving Eq
+instance Show Def where
+ show (Def name inp outp exprs) =
+     name ++ "(" ++ (commify inp) ++ " -> " ++ (commify outp) ++ ") =\n   " ++ (indent (show exprs))
+  where
+   commify x = join "," x
+instance FromTree Def where
+  fromTree (Tree "Def" [name,inp,outp,es] _) =
+     Def (fromTree name) (fromTree inp) (fromTree outp) (fromTree es)
+  fromTree (Tree "Def" q _) = error $ show q
+
+
+
+-- Expr ------------------------------------------------------------------------------
+data Op = Lt | Gt | Leq | Geq | Eq | Neq
+ deriving (Show,Eq)
+instance FromTree Op where
+  fromTree (Tree s _ _) =
+   case s of
+    "==" -> Eq
+    "!=" -> Neq
+    ">=" -> Geq
+    "<=" -> Leq
+    ">"  -> Gt
+    "<"  -> Lt
+
+data Expr  = Seq     [Expr] 
+           | Par     [Expr]
+           | Decl    [(String,String)] Expr
+           | Move    Int Port Port
+           | Copy    Int Port Port
+           | Literal Int Int  Port
+           | While   Port Op Int Expr
+           | 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 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 Expr where
+  fromTree (Tree "Exprs" [(Tree _ decls _), sequents] _) = Decl declist (seq $ map par $ fromTree sequents)
+   where
+         declist = map (\(Tree "::" [shipName,shipType] _) -> ((fromTree shipName), (fromTree shipType))) decls
+         seq []  = Nop
+         seq [x] = x
+         seq x   = Seq x
+         par []  = Nop
+         par [x] = x
+         par x   = Par x
+  fromTree (Tree arrow [source,dests] _) | (arrow=="-->" || arrow=="+->") =
+   case source of
+    (Tree "{" [Tree _ is _] _) -> Par $ concatMap (\d -> map (\(Tree i _ _) -> Literal 1 (read i) d) is) dest
+    (Tree i [] _)              -> rep' dest $ \d -> Literal 1 (read i) d
+    source                     -> case dests of
+                                    (Tree ";" [Tree _ d _] _)      -> rep' dest $ \d -> mc 1 (fromTree source) d
+                                    (Tree "," [Tree _ (d:ds) _] _) ->
+                                       Par $
+                                         ((mc 1 (fromTree source) (fromTree d)):
+                                          (map (\d' -> Copy 1 (fromTree source) d') (map fromTree ds)))
+   where
+    mc = if arrow=="-->" then Move else Copy
+    dest = case dests of
+             (Tree ";" [Tree _ d _] _) -> map fromTree d
+    rep' []   _ = error "nop"
+    rep' [x]  f = f x
+    rep' list f = Par $ map f list
+
+--  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 (Tree "while" [(Tree "Cond" [port, op, (Tree i _ _)] _), e] _) =
+      While (fromTree port) (fromTree op) (read i) (fromTree e)
+  fromTree other = error  $ (show other)
+
+
+\end{code}
\ No newline at end of file