Try5 Parser

Parser.hs

module Language.Try5.Parser where

import Control.Monad

import Control.Monad.Identity

-- import Text.Parsec.Pos
import Text.Parsec.Prim
import Text.Parsec.Expr
import Text.Parsec.Combinator
import Text.Parsec.Error

import Language.Try5.Lexer
import Language.Try5.AST

import Data.List
import Data.Function

import Text.PrettyPrint.HughesPJClass (render, pPrint)

type OperatorParser = Operator String ParserState Identity ExprNode

newtype ParserState = ParserState [(OperatorParser, Rational)]

type TryParser a = ParsecT String ParserState Identity a


parseNode :: TryParser (Expr ExprNode) -> TryParser ExprNode
parseNode p = liftM2 ExprNode getPosition p

parseIdentifier :: TryParser ExprNode
parseIdentifier = parseNode $ liftM (Id None) $ 
               liftM VarId varName 
           <|> liftM TypeId typeName 
           <|> liftM OpId opName


parseExpr :: TryParser ExprNode
parseExpr = do
  ParserState opList <- getState
  let opTable = fmap (fmap fst) $ groupBy ((==) `on` snd) $ reverse $ sortBy (compare `on` snd) opList
  buildExpressionParser opTable parseApply <?> "expression"

apply ::ExprNode -> ExprNode -> ExprNode
apply a@(ExprNode pos _) b = ExprNode pos (Apply a b)

apply2 ::ExprNode -> ExprNode -> ExprNode -> ExprNode
apply2 a b c = apply (apply a b) c

parseApply :: TryParser ExprNode
parseApply = liftM2 (foldl apply) parseFactor (many parseFactor)

parseFactor :: TryParser ExprNode
parseFactor = parens parseExpr 
          <|> parseIdentifier
          -- <|> parseNode (liftM Number parseRational)
          <?> "simple expression"
          
          
parseTypeName :: TryParser TypeName
parseTypeName = liftM2 TypeName getPosition typeName

parseVarName :: TryParser VarName
parseVarName = liftM2 VarName getPosition varName

parseOpName :: TryParser VarName
parseOpName = liftM2 OpName getPosition opName

varToTypeVar :: VarName -> TypeNode
varToTypeVar (VarName pos name) = TypeNode pos $ TVar name
varToTypeVar (OpName pos name) = TypeNode pos $ TVar name

parseDataDef :: TryParser Definition
parseDataDef = do
  reserved "data"
  name <- parseTypeName
  typeVars <- many parseVarName
  fields <- option (zip typeVars $ map varToTypeVar typeVars) $ do
    reservedOp "=>"
    flip sepBy comma $ do
      fieldName <- parseVarName 
      reservedOp "::"
      fieldType <- parseType
      return (fieldName, fieldType)
  return $ DataDef name typeVars fields
  

typeApply ::TypeNode -> TypeNode -> TypeNode
typeApply a@(TypeNode pos _) b = TypeNode pos (TApply a b)

parseTypeNode :: TryParser (Type TypeNode) -> TryParser TypeNode
parseTypeNode p = liftM2 TypeNode getPosition p

parseTypeApply :: TryParser TypeNode
parseTypeApply = liftM2 (foldl typeApply) parseTypeFactor (many parseTypeFactor)

parseType :: TryParser TypeNode
parseType = do
  t <- sepBy1 parseTypeApply (reservedOp "|")
  case t of
    [x] -> return x
    xs  -> parseTypeNode $ return $ TPossible xs
    
parseTypeFactor :: TryParser TypeNode
parseTypeFactor = parens parseTypeApply
              <|> parseTypeNode (liftM TVar varName)
              <|> parseTypeNode (liftM TCons typeName)

parseFuncDef :: TryParser Definition
parseFuncDef = do
    reserved "def"
    name <- parseVarName <|> parseOpName
    firstEq <- parseEquation
    otherEqs <- many $ do
      level <- liftM length (many1 $ reservedOp "|")
      eq <- parseEquation
      return (level, eq)
    return $ FunctionDef name firstEq otherEqs
  where
    parseEquation = do
      params <- many parseFactor
      reservedOp "="
      expr <- parseExpr
      return (params, expr)

parseTypeSynDef :: TryParser Definition
parseTypeSynDef = do
  reserved "type"
  name <- parseTypeName
  typeVars <- many parseVarName
  reservedOp "="
  t <- parseType
  return $ TypeSynDef name typeVars t
  --liftM3 TypeSynDef parseTypeName (many parseVarName) (reservedOp "=" >> parseType)

parseDefinition :: TryParser Definition
parseDefinition = parseDataDef 
              <|> parseFuncDef 
              <|> parseTypeSynDef
              <?> "data, function or value definition"


parseSource :: TryParser TrySource
parseSource = liftM TrySource $ parseLex $ many parseOpDef >> many parseDefinition

parseFile :: FilePath -> IO (Either ParseError TrySource)
parseFile fname = do 
  input <- readFile fname
  return $ seq (length input) $ (runP parseSource (ParserState []) fname input)


test :: IO ()
test = do
  results <- parseFile "test.try"
  case results of
    Left err -> print err
    Right x -> putStrLn $ render $ pPrint x
  
parseLex :: TryParser a -> TryParser a
parseLex p = do 
  whiteSpace
  x <- p
  eof
  return x

parseRational :: TryParser Rational
parseRational = liftM (either toRational toRational) naturalOrFloat

parseOpDef :: TryParser ()
parseOpDef = do
    (op, precidence) <- parseOpType "infixr"  In (flip Infix AssocRight . liftM apply2)
                    <|> parseOpType "infixl"  In (flip Infix AssocLeft . liftM apply2)
                    <|> parseOpType "infix"   In (flip Infix AssocNone . liftM apply2)
                    <|> parseOpType "prefix"  Pre (Prefix . liftM apply)
                    <|> parseOpType "postfix" Post (Postfix . liftM apply)
                    <?> "operator definition"
    modifyState $ \(ParserState opList) -> ParserState ((op, precidence) : opList)
  where
    parseOpType tag fixity p = do
       reserved tag
       name <- operator
       precidence <- parseRational
       return (p $ parseNode $ reservedOp name >> return (Id (fixity precidence) $ OpId name), precidence)