1 files changed, 39 insertions, 65 deletions

diff --git a/src/AST/Pretty.hs b/src/AST/Pretty.hs
index 1ffa980..3473131 100644
--- a/src/AST/Pretty.hs
+++ b/src/AST/Pretty.hs
@@ -41,14 +41,20 @@ instance Monad M where { M f >>= g = M (\i -> let (x, j) = f i in runM (g x) j)
 genId :: M Int
 genId = M (\i -> (i, i + 1))
 
+genName' :: String -> M String
+genName' prefix = (prefix ++) . show <$> genId
+
 genName :: M String
-genName = ('x' :) . show <$> genId
+genName = genName' "x"
 
-genNameIfUsedIn :: STy a -> Idx env a -> Expr x env t -> M String
-genNameIfUsedIn ty idx ex
+genNameIfUsedIn' :: String -> STy a -> Idx env a -> Expr x env t -> M String
+genNameIfUsedIn' prefix ty idx ex
   | occCount idx ex == mempty = case ty of STNil -> return "()"
                                            _ -> return "_"
-  | otherwise                 = genName
+  | otherwise                 = genName' prefix
+
+genNameIfUsedIn :: STy a -> Idx env a -> Expr x env t -> M String
+genNameIfUsedIn = genNameIfUsedIn' "x"
 
 ppExpr :: SList STy env -> Expr x env t -> String
 ppExpr senv e = fst (runM (mkVal senv >>= \val -> ppExpr' 0 val e) 1) ""
@@ -64,6 +70,8 @@ ppExpr' :: Int -> SVal env -> Expr x env t -> M ShowS
 ppExpr' d val = \case
   EVar _ _ i -> return $ showString $ getConst $ valprj val i
 
+  e@ELet{} -> ppExprLet d val e
+
   EPair _ a b -> do
     a' <- ppExpr' 0 val a
     b' <- ppExpr' 0 val b
@@ -155,80 +163,46 @@ ppExpr' d val = \case
                 (Prefix, s) -> s
     return $ showParen (d > 10) $ showString (ops ++ " ") . e'
 
-  EMOne venv i e -> do
-    let venvlen = length (unSList venv)
-        varname = 'v' : show (venvlen - idx2int i)
-    e' <- ppExpr' 11 val e
+  EWith e1 e2 -> do
+    e1' <- ppExpr' 11 val e1
+    let STArr n t = typeOf e1
+    name <- genNameIfUsedIn' "ac" (STAccum n t) IZ e2
+    e2' <- ppExpr' 11 (VPush (Const name) val) e2
     return $ showParen (d > 10) $
-      showString ("one " ++ show varname ++ " ") . e'
+      showString "with " . e1' . showString (" (\\" ++ name ++ " -> ")
+      . e2' . showString ")"
 
-  EMScope e -> do
-    let venv = case typeOf e of STEVM v _ -> v
-        venvlen = length (unSList venv)
-        varname = 'v' : show venvlen
-    e' <- ppExpr' 11 val e
+  EAccum e1 e2 e3 -> do
+    e1' <- ppExpr' 11 val e1
+    e2' <- ppExpr' 11 val e2
+    e3' <- ppExpr' 11 val e3
     return $ showParen (d > 10) $
-      showString ("scope " ++ show varname ++ " ") . e'
-
-  EMReturn _ e -> do
-    e' <- ppExpr' 11 val e
-    return $ showParen (d > 10) $ showString ("return ") . e'
-
-  e@EMBind{} -> ppExprDo d val e
-  e@ELet{} -> ppExprDo d val e
-
-  -- EMBind a b -> do
-  --   let STEVM _ t = typeOf a
-  --   a' <- ppExpr' 0 val a
-  --   name <- genNameIfUsedIn t IZ b
-  --   b' <- ppExpr' 0 (VPush (Const name) val) b
-  --   return $ showParen (d > 10) $ a' . showString (" >>= \\" ++ name ++ " -> ") . b'
+      showString "accum " . e1' . showString " " . e2' . showString " " . e3'
 
   EError _ s -> return $ showParen (d > 10) $ showString ("error " ++ show s)
 
-data Binding = MonadBind String ShowS
-             | LetBind   String ShowS
-
-ppExprDo :: Int -> SVal env -> Expr x env t -> M ShowS
-ppExprDo d val etop = do
-  let collect :: SVal env -> Expr x env t -> M ([Binding], ShowS)
-      collect val' (EMBind lhs body) = do
-        let STEVM _ t = typeOf lhs
-        name <- genNameIfUsedIn t IZ body
-        (binds, core) <- collect (VPush (Const name) val') body
-        lhs' <- ppExpr' 0 val' lhs
-        return (MonadBind name lhs' : binds, core)
+ppExprLet :: Int -> SVal env -> Expr x env t -> M ShowS
+ppExprLet d val etop = do
+  let collect :: SVal env -> Expr x env t -> M ([(String, ShowS)], ShowS)
       collect val' (ELet _ rhs body) = do
         name <- genNameIfUsedIn (typeOf rhs) IZ body
-        (binds, core) <- collect (VPush (Const name) val') body
         rhs' <- ppExpr' 0 val' rhs
-        return (LetBind name rhs' : binds, core)
+        (binds, core) <- collect (VPush (Const name) val') body
+        return ((name, rhs') : binds, core)
       collect val' e = ([],) <$> ppExpr' 0 val' e
 
-      fromLet = \case LetBind n s -> Just (n, s) ; _ -> Nothing
-
   (binds, core) <- collect val etop
 
-  return $ showParen (d > 0) $ case traverse fromLet binds of
-    Just lbinds ->
-      let (open, close) = case lbinds of
-            [_] -> ("{ ", " }")
-            _ -> ("", "")
-      in showString ("let " ++ open)
-         . foldr (.) id
-             (intersperse (showString " ; ")
-                (map (\(name, rhs) -> showString (name ++ " = ") . rhs) lbinds))
-         . showString (close ++ " in ")
-         . core
-    Nothing ->
-      showString "do { "
-      . foldr (.) id
-          (intersperse (showString " ; ")
-             (map (\case MonadBind name rhs -> showString (name ++ " <- ") . rhs
-                         LetBind name rhs -> showString ("let { " ++ name ++ " = ") . rhs
-                                             . showString " }")
-                  binds))
-      . showString " ; " . core . showString " }"
+  let (open, close) = case binds of
+        [_] -> ("{ ", " }")
+        _ -> ("", "")
+  return $ showParen (d > 0) $
+    showString ("let " ++ open)
+    . foldr (.) id
+        (intersperse (showString " ; ")
+           (map (\(name, rhs) -> showString (name ++ " = ") . rhs) binds))
+    . showString (close ++ " in ")
+    . core
 
 data Fixity = Prefix | Infix
   deriving (Show)