destructuring lets and arrows

src/Lib/Elab.idr

@@ -901,7 +901,18 @@ undo ((DoExpr fc tm) :: Nil) = pure tm
 undo ((DoExpr fc tm) :: xs) = pure $ RApp fc (RApp fc (RVar fc "_>>=_") tm Explicit) (RLam fc (BI fc "_" Explicit Many) !(undo xs)) Explicit
 -- undo ((DoExpr fc tm) :: xs) = pure $ RApp fc (RApp fc (RVar fc "_>>_") tm Explicit) !(undo xs) Explicit
 undo ((DoLet fc nm tm) :: xs) = RLet fc nm (RImplicit fc) tm <$> undo xs
-undo ((DoArrow fc nm tm) :: xs) = pure $ RApp fc (RApp fc (RVar fc "_>>=_") tm Explicit) (RLam fc (BI fc nm Explicit Many) !(undo xs)) Explicit
+undo ((DoArrow fc (RVar fc' nm) right []) :: xs) =
+  case lookup nm !get of
+    Just _ => ?todo
+    Nothing =>
+      pure $ RApp fc (RApp fc (RVar fc "_>>=_") right Explicit)
+        (RLam fc (BI fc' nm Explicit Many) !(undo xs)) Explicit
+
+undo ((DoArrow fc left right alts) :: xs) = do
+  let nm = "$sc"
+  rest <- pure $ RCase fc (RVar fc nm) (MkAlt left !(undo xs) :: alts)
+  pure $ RApp fc (RApp fc (RVar fc "_>>=_") right Explicit)
+    (RLam fc (BI fc nm Explicit Many) rest) Explicit
 
 check ctx tm ty = case (tm, !(forceType ctx.env ty)) of
   (RWhere fc decls body, ty) => checkWhere ctx (collectDecl decls) body ty

src/Lib/Parser.idr

@@ -154,6 +154,9 @@ parseOp = do
     | _ => fail "extra stuff"
   pure res
 
+
+
+
 export
 letExpr : Parser Raw
 letExpr = do
@@ -232,13 +235,54 @@ caseExpr = do
   alts <- startBlock $ someSame $ caseAlt
   pure $ RCase fc sc alts
 
-doStmt : Parser DoStmt
-doStmt
-  = DoArrow <$> getPos <*> (try $ ident <* keyword "<-") <*> term
-  <|> DoLet <$> getPos <* keyword "let" <*> ident <* keyword "=" <*> term
-  <|> DoExpr <$> getPos <*> term
-
 doExpr : Parser Raw
+doStmt : Parser DoStmt
+
+caseLet : Parser Raw
+caseLet = do
+  -- look ahead so we can fall back to normal let
+  fc <- getPos
+  try (keyword "let" >> sym "(")
+  pat <- typeExpr
+  sym ")"
+  keyword "="
+  sc <- typeExpr
+  alts <- startBlock $ manySame $ sym "|" *> caseAlt
+  keyword "in"
+  body <- term
+  pure $ RCase fc sc (MkAlt pat body :: alts)
+
+doCaseLet : Parser DoStmt
+doCaseLet = do
+  -- look ahead so we can fall back to normal let
+  -- Maybe make it work like arrow?
+  fc <- getPos
+  try (keyword "let" >> sym "(")
+  pat <- typeExpr
+  sym ")"
+  keyword "="
+  -- arrow <- (False <$ keyword "=" <|> True <$ keyword "<-")
+  sc <- typeExpr
+  alts <- startBlock $ manySame $ sym "|" *> caseAlt
+  bodyFC <- getPos
+  body <- RDo <$> getPos <*> someSame doStmt
+  pure $ DoExpr fc (RCase fc sc (MkAlt pat body :: alts))
+
+doArrow : Parser DoStmt
+doArrow = do
+  fc <- getPos
+  left <- typeExpr
+  Just _ <- optional $ keyword "<-"
+    | _ => pure $ DoExpr fc left
+  right <- term
+  alts <- startBlock $ manySame $ sym "|" *> caseAlt
+  pure $ DoArrow fc left right alts
+
+doStmt
+  = doCaseLet
+  <|> DoLet <$> getPos <* keyword "let" <*> ident <* keyword "=" <*> term
+  <|> doArrow
+
 doExpr = RDo <$> getPos <* keyword "do" <*> (startBlock $ someSame doStmt)
 
 ifThenElse : Parser Raw
@@ -254,6 +298,7 @@ ifThenElse = do
 
 -- This hits an idris codegen bug if parseOp is last and Lazy
 term =  caseExpr
+    <|> caseLet
     <|> letExpr
     <|> lamExpr
     <|> doExpr

src/Lib/Syntax.idr

@@ -60,8 +60,7 @@ public export
 data DoStmt : Type where
   DoExpr : (fc : FC) -> Raw -> DoStmt
   DoLet : (fc : FC) -> String -> Raw -> DoStmt
-  DoArrow : (fc: FC) -> String -> Raw -> DoStmt
-
+  DoArrow : (fc: FC) -> Raw -> Raw -> List RCaseAlt -> DoStmt
 
 data Decl : Type
 data Raw : Type where

src/Lib/Tokenizer.idr

@@ -11,7 +11,7 @@ keywords = ["let", "in", "where", "case", "of", "data", "U", "do",
             "∀", "forall",
             "class", "instance",
             "if", "then", "else",
-             "->", "→", ":", "=>", ":=", "=", "<-", "\\", "_"]
+             "->", "→", ":", "=>", ":=", "=", "<-", "\\", "_", "|"]
 
 checkKW : String -> Token Kind
 checkKW s =