1 files changed, 64 insertions, 8 deletions

diff --git a/src/AST/Pretty.hs b/src/AST/Pretty.hs
index c1d6c88..e793ce1 100644
--- a/src/AST/Pretty.hs
+++ b/src/AST/Pretty.hs
@@ -10,6 +10,7 @@ module AST.Pretty where
 
 import Control.Monad (ap)
 import Data.List (intersperse)
+import Data.Foldable (toList)
 import Data.Functor.Const
 
 import AST
@@ -26,6 +27,10 @@ valprj (VPush x _) IZ = x
 valprj (VPush _ env) (IS i) = valprj env i
 valprj VTop i = case i of {}
 
+vpushN :: Vec n a -> Val (Const a) env -> Val (Const a) (ConsN n TIx env)
+vpushN VNil v = v
+vpushN (name :< names) v = VPush (Const name) (vpushN names v)
+
 newtype M a = M { runM :: Int -> (a, Int) }
   deriving (Functor)
 instance Applicative M where { pure x = M (\i -> (x, i)) ; (<*>) = ap }
@@ -88,11 +93,11 @@ ppExpr' d val = \case
 
   EInl _ _ e -> do
     e' <- ppExpr' 11 val e
-    return $ showParen (d > 10) $ showString "inl " . e'
+    return $ showParen (d > 10) $ showString "Inl " . e'
 
   EInr _ _ e -> do
     e' <- ppExpr' 11 val e
-    return $ showParen (d > 10) $ showString "inr " . e'
+    return $ showParen (d > 10) $ showString "Inr " . e'
 
   ECase _ e a b -> do
     e' <- ppExpr' 0 val e
@@ -104,9 +109,50 @@ ppExpr' d val = \case
       showString "case " . e' . showString (" of { Inl " ++ name1 ++ " -> ") . a'
       . showString (" ; Inr " ++ name2 ++ " -> ") . b' . showString " }"
 
+  EBuild1 _ a b -> do
+    a' <- ppExpr' 11 val a
+    name <- genName
+    b' <- ppExpr' 0 (VPush (Const name) val) b
+    return $ showParen (d > 10) $
+      showString "build1 " . a' . showString (" (\\" ++ name ++ " -> ") . b' . showString ")"
+
+  EBuild _ es e -> do
+    es' <- mapM (ppExpr' 0 val) es
+    names <- mapM (const genName) es
+    e' <- ppExpr' 0 (vpushN names val) e
+    return $ showParen (d > 10) $
+      showString "build ["
+      . foldr (.) id (intersperse (showString ", ") (reverse (toList es')))
+      . showString "] (\\["
+      . foldr (.) id (intersperse (showString ",") (map showString (reverse (toList names))))
+      . showString ("] -> ") . e' . showString ")"
+
+  EFold1 _ a b -> do
+    name1 <- genName
+    name2 <- genName
+    a' <- ppExpr' 0 (VPush (Const name2) (VPush (Const name1) val)) a
+    b' <- ppExpr' 11 val b
+    return $ showParen (d > 10) $
+      showString ("fold1 (\\" ++ name1 ++ " " ++ name2 ++ " -> ") . a'
+      . showString ") " . b'
+
   EConst _ ty v -> return $ showString $ case ty of
     STI32 -> show v ; STI64 -> show v ; STF32 -> show v ; STF64 -> show v ; STBool -> show v
 
+  EIdx1 _ a b -> do
+    a' <- ppExpr' 9 val a
+    b' <- ppExpr' 9 val b
+    return $ showParen (d > 8) $ a' . showString " ! " . b'
+
+  EIdx _ e es -> do
+    e' <- ppExpr' 9 val e
+    es' <- traverse (ppExpr' 0 val) es
+    return $ showParen (d > 8) $
+      e' . showString " ! "
+      . showString "["
+      . foldr (.) id (intersperse (showString ", ") (reverse (toList es')))
+      . showString "]"
+
   EOp _ op (EPair _ a b)
     | (Infix, ops) <- operator op -> do
         a' <- ppExpr' 9 val a
@@ -139,6 +185,22 @@ ppExpr' d val = \case
     e' <- ppExpr' 11 val e
     return $ showParen (d > 10) $ showString ("return ") . e'
 
+  etop@(EMBind _ EMBind{}) -> do
+    let collect :: SVal env -> Expr x env t -> M ([(String, ShowS)], ShowS)
+        collect val' (EMBind lhs cont) = do
+          name <- genName
+          (binds, core) <- collect (VPush (Const name) val') cont
+          lhs' <- ppExpr' 0 val' lhs
+          return ((name, lhs') : binds, core)
+        collect val' e = ([],) <$> ppExpr' 0 val' e
+
+    (binds, core) <- collect val etop
+    return $ showParen (d > 0) $
+      showString "do { "
+      . foldr (.) id (intersperse (showString " ; ")
+                        (map (\(name, rhs) -> showString (name ++ " <- ") . rhs) binds))
+      . showString " ; " . core . showString " }"
+
   EMBind a b -> do
     a' <- ppExpr' 0 val a
     name <- genName
@@ -147,8 +209,6 @@ ppExpr' d val = \case
 
   EError _ s -> return $ showParen (d > 10) $ showString ("error " ++ show s)
 
-  _ -> undefined
-
 data Fixity = Prefix | Infix
   deriving (Show)
 
@@ -160,7 +220,3 @@ operator OLt{} = (Infix, "<")
 operator OLe{} = (Infix, "<=")
 operator OEq{} = (Infix, "==")
 operator ONot = (Prefix, "not")
-
-idx2int :: Idx env t -> Int
-idx2int IZ = 0
-idx2int (IS n) = 1 + idx2int n