Parser.hs

module Language.Melody.Parser (parseMelody, parseMelodyExpr, parseSrcFile) where
import Language.Melody.Syntax
import Text.Parsec
import Text.Parsec.Numbers
import Text.Parsec.String
import Control.Applicative hiding ((<|>), many)
import Control.Monad (void)

parseId :: Parser String
parseId = many1 . oneOf $ "!@#$&*_-+=<>" ++ ['a'..'z'] ++ ['A' .. 'Z']

parseWord :: Parser (Expr NotCompiled)
parseWord = Word <$> parseId

parseQuotedWord :: Parser (Expr NotCompiled)
parseQuotedWord = noClosFunc <$> (char '\'' *> parseWord)

parseFunc :: Parser (Expr NotCompiled)
parseFunc = noClosFunc <$>
            (char '[' *> spaces *> parseExpr <* spaces <* char ']')

parseList :: Parser (Expr NotCompiled)
parseList = do
  char '(' *> spaces
  exprs <- parseExpr `sepBy` (spaces >> char ';' >> spaces)
  void $ spaces *> char ')'
  return $ List exprs

parseDict :: Parser (Expr NotCompiled)
parseDict = do
  char '(' *> spaces
  exprs <- ((,) <$> parseExpr <*> (sep >> parseExpr))
           `sepBy` (spaces >> char ';' >> spaces)
  void $ spaces >> char ')'
  return $ Dictionary exprs
  where sep = spaces >> string "~>" >> spaces

parseNum :: Parser (Expr NotCompiled)
parseNum = NumLit <$> parseFloat

parseStr :: Parser (Expr NotCompiled)
parseStr = StrLit <$> (char '"' *> many (noneOf "\"") <* char '"')

parseBinding :: Parser (Expr NotCompiled)
parseBinding = do
  char '{' >> spaces
  nms <- parseId `sepBy` spaces
  spaces >> char ',' >> spaces
  exprs <- parseExpr `sepBy` spaces
  void $ spaces >> char '}'
  return $ Binding nms exprs

parseExpr :: Parser (Expr NotCompiled)
parseExpr = do
  e  <- p
  es <- try (p `sepBy1` spaces) <|> return []
  return $ if null es then e else Comp (e:es)
  where p = spaces *>
          (parseWord
          <|> parseQuotedWord
          <|> parseFunc
          <|> try parseList -- Backtracking for dictionaries
          <|> parseDict
          <|> parseNum
          <|> parseStr
          <|> parseBinding)

parseDef :: Parser TopLevel
parseDef = do
         char ':' *> spaces
         Word n <- parseWord
         Def n <$> parseExpr

parseType :: Parser TopLevel
parseType = do
  string "type" *> spaces
  name <- parseId <* spaces
  char '=' *> spaces
  cs       <- constr `sepBy1` (spaces *> char '|' *> spaces)
  return $ Type name cs
  where constr = (,) <$> parseId <*> (spaces *> parseIntegral)

parseMultiDef :: Parser TopLevel
parseMultiDef = do
  string "def" *> spaces
  MultiDef <$> parseId <* spaces

parseMultiExt :: Parser TopLevel
parseMultiExt = do
  string "ext" *> spaces
  MultiExt <$> (parseId <* spaces) <*> types <*> parseExpr
    where types = char '[' *> parseId `sepBy` (spaces *> char ';' <* spaces) <* char ']'

parseTopLevel :: Parser TopLevel
parseTopLevel = spaces *>
                (try parseType
                 <|> try parseMultiDef
                 <|> try parseMultiExt
                 <|> parseDef
                 <|> Exec <$> parseExpr)
                <* spaces <* char '.' <* spaces

parseMelody :: String -> Either ParseError TopLevel
parseMelody = parse parseTopLevel "Melody Parser"

parseMelodyExpr :: String -> Either ParseError (Expr NotCompiled)
parseMelodyExpr = parse parseExpr "Melody Parser"

parseSrcFile :: String -> IO (Either ParseError [TopLevel])
parseSrcFile = parseFromFile (many1 parseTopLevel)