parser for a toy programming language

a.hs

parseExprControl =
  do {
        label <- try (do { l <- p_name; p_eq [Spec ":"]; return l})
      ; e <- parseExprControl
      ; return (Label label e)
      }
  <|> do {
        try (p_eq [Spec "def"])
      ; name <- p_name
      ; p_eq [Spec "="]
      ; rval <- parseExprControl
      ; return (Def name rval) }
  <|> do {
        try (p_eq [Spec "\\"])
      ; patterns <- (
          do { try (p_eq [Spec "("]); p_eq [Spec ")"]; return [] }
          <|> p_name `sepBy1` p_eq [Spec ","]
        )
      ; p_eq [Spec "->"]
      ; rval <- parseExprControl
      ; return (Lambda patterns rval)
      }
  <|> do {
        try (p_eq [Spec "if"])
      ; branches <- let p_branches = do {
          p_eq [Spec "("]
        ; conds <- parseExprControl `sepBy1` p_eq [Spec ">>"]
        ; p_eq [Spec ")"]
        ; p_eq [Spec "{"]
        ; body <- parseExprSeq
        ; p_eq [Spec "}"]
        ;     do {  
                try (p_eq [Spec "elif"])
              ; rest <- p_branches
              ; return ((conds, body) : rest)
              }
          <|> return [(conds, body)]
        } in p_branches
      ; else_part <- option [] (do {
                                try (p_eq [Spec "else"])
                              ; p_eq [Spec "{"]
                              ; body <- parseExprSeq
                              ; p_eq [Spec "}"]
                              ; return body
                              })
      ; return $ If branches else_part
      }
  <|> do {
        try (p_eq [Spec "loop"])
      ; name <- option Nothing (p_name >>= return . Just)
      ; p_spec "("
      ; conds <- parseExprControl `sepBy1` p_eq [Spec ">>"]
      ; p_spec ")"
      ; p_spec "{"
      ; body <- parseExprSeq
      ; p_spec "}"
      ; return $ Loop name conds body
      }
  <|> do {
        try (p_spec "break")
      ; name <- p_name
      ; return $ Break name
      }
  <|> do {
        try (p_eq [Spec "&"])
      ; name <- p_name
      ; return (Ref name)
      }
  <|> parseExprOr
  where
    p_spec str = p_eq [Spec str]

p_name = p_test "name" testName
  where
    testName (Sym name) = Just name
    testName _ = Nothing

parseExprSeq = (parseExprControl <|> return Void) `sepBy1` p_eq [Spec ";"]

parseExprOr = parseExprAnd `chainr1` parseOperator ["||"]

parseExprAnd = parseExprNot `chainr1` parseOperator ["&&"]

parseExprNot =
  do {
    try (p_eq [Spec "not"])
  ; e <- parseExprCompare
  ; return $ CallFunction (Var "not") [e]
  } <|> parseExprCompare

parseExprCompare = parseExprAdd `chainr1` parseOperator ["<", ">", "=", "!=", "<=", ">="]

parseExprAdd = parseExprMul `chainr1` parseOperator ["+", "-"]

parseExprMul = parseExprCall `chainr1` parseOperator ["*", "/"]

parseExprCall =
  do {
    e0 <- parseExprAtom
  ; let {
      p e =
          do {
            try (p_eq [Spec "("])
          ; args <- option [] (parseExprControl `sepBy` p_eq [Spec ","])
          ; p_eq [Spec ")"]
          ; p $ CallFunction e args
          }
      <|> do {
            try (p_eq [Spec "."])
          ; name <- p_name
          ; p_eq [Spec "("]
          ; args <- option [] (parseExprControl `sepBy` p_eq [Spec ","])
          ; p_eq [Spec ")"]
          ; p $ CallMethod e name args
          }
      <|> return e
      }
  ; p e0
  }

parseOperator ops =
  do
    Spec op <- p_eq (map Spec ops)
    return $ \o1 o2 -> CallFunction (Var op) [o1, o2]

parseExprAtom =
      try (p_test "atom" testAtom)
  <|> do {
        try (p_eq [Spec "{"])
      ; exprs <- parseExprSeq
      ; p_eq [Spec "}"]
      ; return (Seq exprs)
      }
  <|> do {
        try $ p_eq [Spec "("]
      ; expr <- parseExprControl
      ; p_eq [Spec ")"]
      ; return (expr)
      }
  where
    testAtom (TInt num) = Just (LInt num)
    testAtom (TStr str) = Just (LString str)
    testAtom (Sym name) = Just (Var name)
    testAtom _ = Nothing