Do translation.

app/Main.hs

@@ -25,8 +25,8 @@ import Translate(translateString, drawingsFromModule)
 -- Move tests out of main.
 
 -- TODO Later --
--- Translate Do.
 -- Consider making lines between patterns Pattern Color when the line is a reference.
+-- Consider using seperate parameter icons in functions.
 -- Make constructors in patterns PatternColor.
 -- Add function name and type to LambdaIcons.
 -- Let each bool, value pair in Guard icon be flipped to reduce line crossings. Do the same for case.
@@ -286,6 +286,16 @@ specialTests = [
   "yyyyy = fffff xxxxx"
   ]
 
+doTests = [
+  "y = do {x1}",
+  "y = do {x1; x2}",
+  "y = do {x1; x2; x3}",
+  "y = do {x1 <- m1; x2}",
+  "y = do {(x1, x2) <- m1; x1 + x2}",
+  "y = do {x1 <- m1; x2 <- f x1; g x2}",
+  "y = do {let {x = 1}; x2 <- x; f x2}"
+  ]
+
 enumTests = [
   "y = [1..]",
   "y = [1,2..]",
@@ -413,7 +423,8 @@ otherTests = [
   ]
 
 testDecls = mconcat [
-  enumTests
+  doTests
+  ,enumTests
   ,caseTests
   ,lambdaTests
   ,guardTests

app/Translate.hs

@@ -299,6 +299,16 @@ evalRightSection c op e = do
 evalEnums :: EvalContext -> String -> [Exp] -> State IDState (IconGraph, Reference)
 evalEnums c s exps = fmap Right <$> evalApp c (Var . UnQual . Ident $ s, exps)
 
+makeQVarOp = QVarOp . UnQual . Ident
+
+desugarDo :: [Stmt] -> Exp
+desugarDo [Qualifier e] = e
+desugarDo (Qualifier e : stmts) = InfixApp e thenOp (desugarDo stmts)
+  where thenOp = makeQVarOp ">>"
+desugarDo (Generator srcLoc pat e : stmts) =
+  InfixApp e  (makeQVarOp ">>=") (Lambda srcLoc [pat] (desugarDo stmts))
+desugarDo (LetStmt binds : stmts) = Let binds (desugarDo stmts)
+
 evalExp :: EvalContext  -> Exp -> State IDState (IconGraph, Reference)
 evalExp c x = case x of
   Var n -> evalQName n c
@@ -310,6 +320,7 @@ evalExp c x = case x of
   Let bs e -> evalLet c bs e
   If e1 e2 e3 -> fmap Right <$> evalIf c e1 e2 e3
   Case e alts -> fmap Right <$> evalCase c e alts
+  Do stmts -> evalExp c (desugarDo stmts)
   -- TODO special tuple symbol
   Tuple _ exps -> fmap Right <$> evalTuple c exps
   List exps -> fmap Right <$> evalListExp c exps