rose/Rose/Parser/Forms.idr

||| Module Parser defines a parser for the Rose language.
module Rose.Parser

import Text.Parser
import Text.Parser.Core
import Lexer
import Text.Lexer
import Data.Atom
import Data.SExpression
import Data.Form

reservedWords : List String
reservedWords = ["let", "def", "macro", "fn", "where"]

checkReserved : Rule SE -> Rule SE
checkReserved r = join $ pure isReserved <*> r
  where  isReserved : SE -> Grammar ParsedToken False SE
         isReserved (MkAtom (MkSymbol name)) = if (not $ name `elem` reservedWords)
                                              then pure $ MkAtom (MkSymbol name)
                                              else (fail (ReservedWord name))
         isReserved x = pure x
         ReservedWord : String -> String
         ReservedWord word =
           "The symbol " ++ word ++ " is reserved. Use a different symbol, such as x."

reserved : String -> Rule SE
reserved s = terminal 
  (\x => case (tok x) of 
         (TkSymbol s') => if s == s' then (Just $ MkAtom (MkSymbol s)) else Nothing
         _ => Nothing)

manyEnclosed : Rule ty -> Rule (List ty)
manyEnclosed r = (lparen *> manyTill rparen r) 
               <|> (lbrack *> manyTill rbrack r)

someEnclosed : Rule ty -> Rule (List ty)
someEnclosed r = (lparen *> someTill rparen r) 
               <|> (lbrack *> someTill rbrack r)

enclosed : Grammar ParsedToken t ty -> Rule ty
enclosed r =
  (between lbrack rbrack r) <|> (between lparen rparen r)

mutual
  ||| Let forms
  ||| (let [binding value...] body)
  export
  lett : Rule SE
  lett =
    enclosed
    $ reserved "let"
      *> manyEnclosed bindings
      >>= \bs => (atoms <|> expression)
      >>= \body => pure $ fromList (bs ++ [body])
    where bindings : Rule SE
          bindings =
             checkReserved symbol
             >>= \binding => (atoms <|> expression) </> UnevenLetBindings binding
             >>= \value => pure $ (Expression binding value)
          UnevenLetBindings : SE -> String
          UnevenLetBindings binding =
            "Uneven let bindings. Let bindings must contain an even number of names and values: (let [binding value] body)"
            ++ "\n\t"
            ++ "The binding " ++ show binding ++ " should be followed by a value or expression." 

  ||| Where forms
  ||| (where x (fn [] 2)
  |||        y 2)
  export
  wheref : Rule SE
  wheref =
    lparen
    *> reserved "where"
    *> manyTill rparen bindings
    >>= \bs => pure $ fromList bs
    where bindings : Rule SE
          bindings =
            checkReserved symbol
            >>= \name => (fn <|> macro <|> app <|> atoms) </> UnevenWhereBindings name
            >>= \value => pure $ Expression name value
          UnevenWhereBindings : SE -> String
          UnevenWhereBindings binding =
            "Uneven where bindings. Where bindings must contain an even number of names and values: (where binding value...)"
            ++ "\n\t"
            ++ "The binding " ++ show binding ++ " should be followed by a value or expression." 
  
  ||| Anonymous macros
  ||| (macro [x] foo)
  export
  macro : Rule SE
  macro =
    enclosed 
    $ reserved "macro"
    *> pattern
    where pattern : Rule SE
          pattern =
            pure fromList
            <*> manyEnclosed (checkReserved atoms) </> MissingMacroArgList
            >>= \args => (atoms <|> macro <|> expression) </> MissingMacroBody args
            >>= \body => pure $ (Expression args body)
          MissingMacroArgList : String
          MissingMacroArgList =
            "Expected a list of arguments or pattern matches."
            ++ "\n\t"
            ++ "Macros take an even number of argument lists and bodies."
          MissingMacroBody : SE -> String
          MissingMacroBody pat = 
            "Missing macro body. Macros must contain an argument list and function body: (macro [x] 1)"
            ++ "\n\t"
            ++ "The arguments " ++ show pat ++ " should be followed by a function body." 

  app : Rule SE
  app =
    enclosed
    $ (symbol <|> fn <|> macro)
      >>= \f => many (atoms <|> expression)
      >>= \args => pure $ Expression f (fromList args)
 
  ||| Anonymous functions
  ||| (fn [0] 1
  |||     [n] (- n 1))
  export
  fn : Rule SE
  fn =
    enclosed
    $ reserved "fn"
      *> many patterns
      >>= \pats => pure $ fromList pats
    where patterns =
            manyEnclosed atoms
            >>= \args => (atoms <|> lett <|> fn <|> app) </> InvalidFunctionBody args
            >>= \body => pure $ (Expression (fromList args) body)
          InvalidFunctionBody : (List SE) -> String
          InvalidFunctionBody args =  
            "Invalid function body. Functions must contain an argument list and function body: (fn [x] 1)"
            ++ "\n\t"
            ++ "The arguments " ++ show args ++ " should be followed by a function body."

  export
  def : Rule SE
  def =
    enclosed
    $ reserved "def"
      *> symbol
      >>= \name => (atoms <|> expression) </> MissingDefinitionBody
      >>= \body => pure $ Expression name body
    where MissingDefinitionBody : String
          MissingDefinitionBody = "Expected a definition body."

||| A program is a list of s-expressions
export
program : Grammar ParsedToken False (List SE)
program =
  manyTill eof list